📄 frmintegration.frm
字号:
aRs("MenuType") = Trim(ftMenuTyp.Text)
End If
If Trim(ftDescription.Text) <> "" Then
aRs("MenuDescription") = Trim(ftDescription.Text)
End If
aRs.Update
UpdateNo "酒席配置"
'添加到列表中
InsertToIntegration lstPro, stmpID, Trim(ftMenuName.Text), ftPrice.Text, Trim(ftMenuTyp.Text), Trim(ftDescription.Text)
Else
aRs.Close
Set aRs = Nothing
aDB.Close
Set aDB = Nothing
MsgBox "编号【" & stmpID & "】已经存在, " & vbCrLf _
& "系统将自动更新编号或手工修改后继续？ ", vbExclamation
UpdateNo "酒席配置"
ftMenuID.Text = GetNo("酒席配置")
ftMenuID.SetFocus
Exit Sub
End If
aRs.Close
Set aRs = Nothing
aDB.Close
Set aDB = Nothing
'重新添加新的酒席
ftMenuID.Text = GetNo("酒席配置")
ftPrice.Text = "0"
ftMenuName.Text = ""
ftMenuTyp.Text = ""
ftDescription.Text = ""
ftMenuName.SetFocus
Exit Sub
AddERR:
MsgBox "添加错误:" & Err.Description, vbCritical
End Sub
Private Sub cmdClos_Click()
Unload Me
End Sub
Private Sub cmdDel_Click()
If lstPro.ListItems.Count = 0 Then Exit Sub
If lstPro.SelectedItem.Text = "" Then Exit Sub
If lstDetail.ListItems.Count = 0 Then Exit Sub
If lstDetail.SelectedItem.Text = "" Then Exit Sub
If MsgBox("真的要删除〖" & lstPro.SelectedItem.SubItems(1) & "〗酒席 " & vbCrLf _
& "中【" & lstDetail.SelectedItem.SubItems(1) & "】,吗？(Y/N) ", vbYesNo + vbInformation) = vbNo Then Exit Sub
If DeleteMenuCatDetail(lstDetail.SelectedItem.Text, lstPro.SelectedItem.Text, "tbdMenuCat") = True Then
lstDetail.ListItems.Remove lstDetail.SelectedItem.Index
End If
End Sub
Private Sub cmdDelCat_Click()
If lstPro.ListItems.Count = 0 Then Exit Sub
If lstPro.SelectedItem.Text = "" Then Exit Sub
If MsgBox("真的要删除〖" & lstPro.SelectedItem.SubItems(1) & "〗酒席吗？(Y/N) ", vbYesNo + vbInformation) = vbNo Then Exit Sub
If DeleteMenuCat(lstPro.SelectedItem.Text, "tbdMenuCat") = True Then
lstPro.ListItems.Remove lstPro.SelectedItem.Index
'同时清除明细表
lstDetail.ListItems.Clear
End If
End Sub
Private Sub cmdSelect_Click()
frmSelectMenus.Show 1
If sMenuName <> "" Then
ftID.Text = sMenuName
If Trim(ftID.Text) <> "" Then
'给出菜单名称
Dim sTmp As String
sTmp = GetProName(Trim(ftID.Text))
If sTmp = "" Then
ftName.Text = ""
ftID.Text = ""
'MsgBox "对不起,您输入的编号不存在。 ", vbExclamation
Else
ftName.Text = sTmp
End If
Else
ftName.Text = ""
End If
ftID.Enabled = False
ftNum.SetFocus
ftID.Enabled = True
Else
ftID.SetFocus
End If
End Sub
Private Sub Form_Load()
GetFormSet Me, frmMain
IntegrationFocus = True
'刷新预订信息,显示所有预订信息
frmMain.lbControl.Caption = "酒席配置"
Screen.MousePointer = 11
'给出菜类型列表+++++++++++++++++++++++++++++++++++++++++
GetTypeList "MenuType", cmbType
'给出酒席内容
GetIntegration
ftMenuID.Text = GetNo("酒席配置")
Screen.MousePointer = 0
End Sub
Private Sub Form_Resize()
On Error Resume Next
If Me.WindowState = 1 Then Exit Sub
'常规时
If Me.WindowState = 0 Then
Me.Move 1, 1, frmMain.Width - (frmMain.picTool.Width + 200), frmMain.Height - (frmMain.picADV.Height + 1150)
End If
Frame2.Height = Me.Height - 800 - Frame1.Height
Frame2.Width = Me.Width - 400
Frame1.Width = Frame2.Width
lstDetail.Height = Frame2.Height - 1300
lstDetail.Width = Frame2.Width - 150
lstPro.Width = lstDetail.Width
ftDescription.Width = lstPro.Width - 4950
cmdClos.Left = lstPro.Width - cmdClos - 1500
End Sub
Private Sub Form_Unload(Cancel As Integer)
SaveFormSet Me
IntegrationFocus = False
End Sub
Private Sub ftID_DblClick()
Call cmdSelect_Click
End Sub
Private Sub ftID_LostFocus()
If Trim(ftID.Text) <> "" Then
'给出菜单名称
Dim sTmp As String
sTmp = GetProName(Trim(ftID.Text))
If sTmp = "" Then
ftName.Text = ""
ftID.Text = ""
'MsgBox "对不起,您输入的编号不存在。 ", vbExclamation
Else
ftName.Text = sTmp
End If
Else
ftName.Text = ""
End If
End Sub
Private Sub ftName_DblClick()
Call cmdSelect_Click
End Sub
Private Sub ftNum_Change()
If ftNum.Text = "" Then
ftNum.Text = "1"
ftNum.SelStart = 0
ftNum.SelLength = 1
Exit Sub
End If
If ftNum.Text = "." Then
ftNum.Text = "0."
ftNum.SelStart = 2
ftNum.SelLength = 0
Exit Sub
End If
End Sub
Private Sub ftPrice_Change()
If ftPrice.Text = "" Then
ftPrice.Text = "1"
ftPrice.SelStart = 0
ftPrice.SelLength = 1
Exit Sub
End If
If ftPrice.Text = "." Then
ftPrice.Text = "0."
ftPrice.SelStart = 2
ftPrice.SelLength = 0
Exit Sub
End If
End Sub
Private Sub lstDetail_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
On Error Resume Next
'排序操作
If lstDetail.ListItems.Count > 0 Then
lstDetail.SortKey = ColumnHeader.Index - 1
lstDetail.Sorted = True
If lstDetail.SortOrder = lvwAscending Then
lstDetail.SortOrder = lvwDescending
Else
lstDetail.SortOrder = lvwAscending
End If
End If
End Sub
Private Sub lstPro_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
On Error Resume Next
'排序操作
If lstPro.ListItems.Count > 0 Then
lstPro.SortKey = ColumnHeader.Index - 1
lstPro.Sorted = True
If lstPro.SortOrder = lvwAscending Then
lstPro.SortOrder = lvwDescending
Else
lstPro.SortOrder = lvwAscending
End If
End If
End Sub
Private Sub GetIntegration()
On Error GoTo Ett
lstPro.ListItems.Clear
Me.MousePointer = 11
Dim iDB As Connection
Dim iRS As Recordset
Set iDB = CreateObject("ADODB.Connection")
Set iRS = CreateObject("ADODB.Recordset")
iDB.Open Constr
iRS.Open "Select * from tbdMenuCat", iDB, adOpenStatic, adLockReadOnly, adCmdText
If Not (iRS.EOF And iRS.BOF) Then
Do While Not iRS.EOF
InsertToIntegration lstPro, iRS("MenuID"), iRS("MenuName"), iRS("MenuPrice"), NullValue(iRS("MenuType")), NullValue(iRS("MenuDescription"))
iRS.MoveNext
Loop
End If
iRS.Close
Set iRS = Nothing
iDB.Close
Set iDB = Nothing
Me.MousePointer = 0
Exit Sub
Ett:
Me.MousePointer = 0
MsgBox "给出酒席错误:" & Err.Description, vbCritical
Exit Sub
End Sub
Private Sub InsertToIntegration(tmpView As ListView, sText1 As String, sText2 As String, sText3 As String _
, sText4 As String, sText5 As String)
On Error Resume Next
If Trim(sText1) = "" Then Exit Sub
Dim lstTmp As ListItem
Set lstTmp = tmpView.ListItems.Add
lstTmp.Text = Trim(sText1)
lstTmp.SubItems(1) = Trim(sText2)
lstTmp.SubItems(2) = Trim(sText3)
lstTmp.SubItems(3) = Trim(sText4)
lstTmp.SubItems(4) = Trim(sText5)
End Sub
Private Sub lstPro_ItemClick(ByVal Item As MSComctlLib.ListItem)
If lstPro.ListItems.Count > 0 Then
If lstPro.SelectedItem.Text <> "" Then
Frame2.Caption = "【" & lstPro.SelectedItem.SubItems(1) & "】酒席菜单列表"
'给出配菜明细
GetIntegrationDetail lstPro.SelectedItem.Text
End If
Else
Frame2.Caption = "配菜明细表"
End If
End Sub
Private Sub GetIntegrationDetail(IDs As String)
On Error GoTo Ett
lstDetail.ListItems.Clear
Me.MousePointer = 11
Dim iDB As Connection
Dim iRS As Recordset
Set iDB = CreateObject("ADODB.Connection")
Set iRS = CreateObject("ADODB.Recordset")
iDB.Open Constr
iRS.Open "Select tbdMenuCatDetail.MenuID,tbdMenuCatDetail.MenuName,tbdMenuCatDetail.MenuNum,tbdMenuCatDetail.MenuTYpe," _
& "EatList.MName from tbdMenuCatDetail Inner Join EatList On tbdMenuCatDetail.MenuName=EatList.MID " _
& " Where tbdMenucatDetail.MenuID='" & IDs & "'", iDB, adOpenStatic, adLockReadOnly, adCmdText
If Not (iRS.EOF And iRS.BOF) Then
Do While Not iRS.EOF
'MenuName为菜单编号，MName为菜单名称
InsertToIntegrationDetail lstDetail, iRS("MenuName"), iRS("MName"), iRS("MenuNum"), NullValue(iRS("MenuType"))
iRS.MoveNext
Loop
Else
iRS.Close
Set iRS = Nothing
iDB.Close
Set iDB = Nothing
Me.MousePointer = 0
'MsgBox "没有找到编号为〖" & IDs & "〗的酒席明细表,请重新建立。 ", vbExclamation
Exit Sub
End If
iRS.Close
Set iRS = Nothing
iDB.Close
Set iDB = Nothing
Me.MousePointer = 0
Exit Sub
Ett:
Me.MousePointer = 0
MsgBox "给出酒席明细错误:" & Err.Description, vbCritical
Exit Sub
End Sub
Private Sub InsertToIntegrationDetail(tmpView As ListView, sText1 As String, sText2 As String, sText3 As String _
, sText4 As String)
On Error Resume Next
If Trim(sText1) = "" Then Exit Sub
Dim lstTmp As ListItem
Set lstTmp = tmpView.ListItems.Add
lstTmp.Text = Trim(sText1)
lstTmp.SubItems(1) = Trim(sText2)
lstTmp.SubItems(2) = Trim(sText3)
lstTmp.SubItems(3) = Trim(sText4)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -