Распечатка программы
'---------------------------------------------------------------
'Код для модуля меню
'-------------------------------------------------------------------------------------------------------------------
Sub SetupMenu()
With Worksheets("Сп.заказов")
.Activate
.Rows("2:2").Select
ActiveWindow.FreezePanes = True
End With
Range("A1:L1").Select
With Selection
.Font.Bold = True
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignBottom
With .Interior
.ColorIndex = 36
.Pattern = xlSolid
End With
End With
Range("A1").Select
With Application
.DisplayFormulaBar = False
.DisplayStatusBar = False
.CommandBars("Formatting").Visible = False
.CommandBars("Standard").Visible = False
End With
With ActiveWindow
.DisplayVerticalScrollBar = True
.DisplayHorizontalScrollBar = False
End With
MenuBars(xlWorksheet).Menus.Add Caption:="&База", before:=9
MenuBars(xlWorksheet).Menus("&База").MenuItems.Add _
Caption:="&Выход", before:=1, OnAction:="Quit"
MenuBars(xlWorksheet).Menus("&База").MenuItems.Add _
Caption:="&Сохранение", before:=1, OnAction:="SaveBd"
MenuBars(xlWorksheet).Menus("&База").MenuItems.Add _
Caption:="Р&едактирование", before:=1, OnAction:="StartRedact"
MenuBars(xlWorksheet).Menus("&База").MenuItems.Add _
Caption:="&Регистрация", before:=1, OnAction:="StartRegister"
MenuBars(xlWorksheet).Menus("&База").MenuItems.Add _
Caption:="&Меню", before:=1, OnAction:="Ret"
End Sub
Sub DeleteMenus()
With Application
.DisplayFormulaBar = True
.DisplayStatusBar = True
.CommandBars("Formatting").Visible = True
.CommandBars("Standard").Visible = True
End With
With ActiveWindow
.DisplayHorizontalScrollBar = True
End With
For Each MenuName In MenuBars(xlWorksheet).Menus
If MenuName.Caption = "&База" Then
MenuName.Delete
End If
Next
End Sub
'---------------------------------------------------------------
'Код для основных действий программы
'-------------------------------------------------------------------------------------------------------------------
'Регистрация нового заказа
Sub StartRegister()
Worksheets("Фон").Activate
NewTur = True
With frmData
With .cmdv1
.Visible = True
.Default = True
.ControlTipText = "Занести новый заказ"
End With
With .cmdv2
.Visible = True
.Default = True
.ControlTipText = "Выйти в главное меню"
End With
.cmdf1.Visible = False
.cmdf2.Visible = False
.Caption = "Регистрация заказа"
ClearForm
.Show
End With
End Sub
'Редактирование заказа
Sub StartRedact()
Worksheets("Фон").Activate
NewTur = False
With frmData
With .cmdv1
.Visible = True
.Default = True
.ControlTipText = "Изменить старый заказ"
End With
With .cmdv2
.Visible = True
.Default = True
.ControlTipText = "Выйти в главное меню"
End With
.cmdf1.Visible = True
.cmdf2.Visible = True
.Caption = "Редактирование заказа"
.cmdf1.ControlTipText = "Найти заказ"
.cmdf2.ControlTipText = "Удалить из базы"
If FoundRow = 0 Then frmFind.Show Else .Show
End With
End Sub
Sub Quit()
Dim sav As Integer
If ActiveWorkbook.Saved = False Then
sav = MsgBox("Сохранить документ?", vbYesNoCancel, "БД")
If sav = vbCancel Then Exit Sub
If sav = vbYes Then
DeleteMenus
ActiveWorkbook.Close True
Else
DeleteMenus
ActiveWorkbook.Close False
End If
End If
DeleteMenus
ActiveWorkbook.Close False
End Sub
'очистка формы
Sub ClearForm()
Dim i As Integer
With frmData
.txt1 = ""
.txt2 = ""
.txt3 = ""
.txt4 = ""
.txt5 = ""
.txt6 = ""
.txt7 = ""
.txt8 = ""
.txt9 = ""
.comb1 = ""
.comb1.Clear
.comb1.AddItem "ж\д", 0
.comb1.AddItem "авиа", 1
.comb1.AddItem "судоход", 2
.comb1.AddItem "грузовики", 3
.comb1.AddItem "не важно", 4
.comb1.Text = .comb1.List(0)
.chb1.Value = 0
.chb2.Value = 0
.chb3.Value = 0
.chb4.Value = 0
.chb5.Value = 0
.chb6.Value = 0
End With
End Sub
'Добавление заказа в таблицу
Sub AddZak()
Dim Range As Object
Dim NewRow As Integer
Dim i As Integer
Set Range = Worksheets("Сп.заказов").Cells(1, 1).CurrentRegion
With frmData
Data(1) = .txt1.Text
Data(2) = .txt2.Text
Data(3) = .txt3.Text
Data(4) = .txt4.Text
Data(6) = .txt5.Text
Data(7) = .txt6.Text
Data(8) = .txt7.Text
Data(9) = .txt9.Text
Data(10) = .comb1.Text
If .pro.Value = True Then
Data(12) = "Предоплата"
Else
Data(12) = "Аккредитив"
End If
If .pok.Value = True Then
Data(13) = "Покупка"
Else
Data(13) = "Продажа"
End If
If .chb1.Value = True Then
Data(14) = "Да"
Else
Data(14) = "Нет"
End If
If .chb2.Value = True Then
Data(15) = "Да"
Else
Data(15) = "Нет"
End If
If .chb3.Value = True Then
Data(16) = "Да"
Else
Data(16) = "Нет"
End If
If .chb4.Value = True Then
Data(17) = "Да"
Else
Data(17) = "Нет"
End If
If .chb5.Value = True Then
Data(18) = "Да"
Else
Data(18) = "Нет"
End If
If .chb6.Value = True Then
Data(19) = "Да"
Else
Data(19) = "Нет"
End If
End With
NewRow = Range.Rows.Count + 1
For i = 1 To 13
With Worksheets("Сп.заказов")
.Cells(NewRow, i).Value = Data(i)
End With
Next i
FoundRow = NewRow
End Sub
'Поиск заказа
Sub FindZak()
Dim RowRng As Object
Dim NameCl As Variant
Dim Zakaz, Tovar As Variant
Dim Row, i As Integer
Set RowRng = Worksheets("Сп.заказов").Cells(1, 1).CurrentRegion
With frmFind
Zakaz = .ComboBox1.Text
Tovar = .ComboBox2.Text
.ComboBox1.Text = ""
.ComboBox2.Text = ""
End With
Row = RowRng.Rows.Count
With Worksheets("Сп.заказов")
For i = 2 To Row
If Zakaz = .Cells(i, 1).Value And Tovar = .Cells(i, 6).Value Then
FoundRow = i
frmFind.Hide
MsgBox "Нашли заказ.." & Chr(10) & "Редактируем!", vbOKOnly + vbInformation, "Есть заказ"
frmData.Show
Exit Sub
End If
Next i
End With
MsgBox "Нет такого заказа в базе" & Chr(10) & "Повторите поиск", vbOKOnly + vbInformation
End Sub
'Редактирование найденного заказа
Sub EditZak()
Dim Row, i As Integer
Row = FoundRow
With frmData
For i = 1 To 13
Data(i) = Worksheets("Сп.заказов").Cells(Row, i).Value
Next i
Data(1) = .txt1.Text
Data(2) = .txt2.Text
Data(3) = .txt3.Text
Data(4) = .txt4.Text
Data(6) = .txt5.Text
Data(7) = .txt6.Text
Data(8) = .txt7.Text
Data(9) = .txt9.Text
Data(10) = .comb1.Text
If .pro.Value = True Then
Data(12) = "Предоплата"
Else
Data(12) = "Аккредитив"
End If
If .pok.Value = True Then
Data(13) = "Покупка"
Else
Data(13) = "Продажа"
End If
If .chb1.Value = True Then
Data(14) = "Да"
Else
Data(14) = "Нет"
End If
If .chb2.Value = True Then
Data(15) = "Да"
Else
Data(15) = "Нет"
End If
If .chb3.Value = True Then
Data(16) = "Да"
Else
Data(16) = "Нет"
End If
If .chb4.Value = True Then
Data(17) = "Да"
Else
Data(17) = "Нет"
End If
If .chb5.Value = True Then
Data(18) = "Да"
Else
Data(18) = "Нет"
End If
If .chb6.Value = True Then
Data(19) = "Да"
Else
Data(19) = "Нет"
End If
End With
End Sub
'Удаление найденного заказа
Sub DeleteZak()
Dim temp As Integer
temp = MsgBox("Точно точно удалить???", vbYesNoCancel, "Удаление")
If temp = vbCancel Then
frmData.Hide
frmStart.Show
End If
If temp = vbYes Then
Dim Range As Object
Dim LastRow, i, j As Integer
With Worksheets("Сп.заказов")
Set Range = .Cells(1, 1).CurrentRegion
LastRow = Range.Rows.Count + 1
For i = FoundRow + 1 To LastRow
For j = 1 To 13
.Cells(i - 1, j).Value = .Cells(i, j).Value
Next j
Next i
End With
ClearForm
FoundRow = 0
frmData.Hide
MsgBox "Данные удалены!"
frmStart.Show
End If
End Sub