РАСПЕЧАТКА ПРОГРАММЫ
'--------------------------------------------------------------- 'Код для модуля меню '------------------------------------------------------------------------------------------------------------------- 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
|
