frmeatlist.frm

星级酒店管理系统（附带系统自写控件源码）

   On Error GoTo GetERR
   
   Dim utDB As Connection
   Set utDB = CreateObject("ADODB.Connection")
       utDB.Open Constr
       utDB.BeginTrans
       utDB.Execute "Delete From EatList Where MID='" & sName & "'"
       utDB.Execute "Delete From Cust Where CID='" & sName & "'"
       utDB.Execute "Delete From tmpCust1 Where CID='" & sName & "'"
       utDB.Execute "Delete From tmpCust Where CID='" & sName & "'"
       utDB.CommitTrans
       utDB.Close
       Set utDB = Nothing
       DeleteEatList = True
       
   Exit Function
GetERR:
   DeleteEatList = False
   MsgBox "删除错误:" & Err.Description, vbCritical
   
End Function

Private Sub cmdModify_Click()
 
 On Error Resume Next
 
 If cmdModify.Caption = "取消" Then
    lstPro.Enabled = True
    Strip1.Enabled = True
    If lstPro.SelectedItem.Text <> "" Then cmdDel.Enabled = True
    cmdAdd.Caption = "添加输入的新菜(&A)"
    cmdModify.Caption = "修改选定的菜单(&M)"
    txtCode = "": txtPM = "": txtPingYin = "": txtDJ = "0"
    txtPM.SetFocus
    Old_Code = ""
    txtPM.SetFocus
    '取消代码---------------------------------------------
  Else
    '修改
    lstPro.Enabled = False
    Strip1.Enabled = False
    Old_Code = lstPro.SelectedItem.Text
    cmdModify.Caption = "取消"
    cmdAdd.Caption = "保存"
    cmdDel.Enabled = False
   '给出值
    txtCode.Text = lstPro.SelectedItem.Text
    txtPM.Text = lstPro.SelectedItem.SubItems(1)
    txtPingYin.Text = lstPro.SelectedItem.SubItems(2)
    txtDJ.Text = lstPro.SelectedItem.SubItems(3)
    cmbType.Text = lstPro.SelectedItem.SubItems(5)
    txtDW.Text = lstPro.SelectedItem.SubItems(4)
    txtPM.SetFocus
  End If
  
End Sub

Private Sub cmdPrint_Click()

 If lstPro.ListItems.Count = 0 Then Exit Sub
 
'打印列表
    If MsgBox("真的要打印【菜名列表】吗？(Y/N)   " & vbCrLf _
         & "请设置打印机的纸张：A4 纵向   " & vbCrLf & vbCrLf _
         & "如果需要打印所有物品,请在菜分类上选择(所有物品)后,再打印。   ", vbInformation + vbYesNo) = vbNo Then
       Exit Sub
    End If
 
    Dim ptGrid As listViewPrint
 
   '建立打印对象
    On Error GoTo Err1
    
    Dim strPageLeft As String
    Dim strPageTop As String
    Dim PageTop As Long
    Dim PageLeft As Long

Set ptGrid = New listViewPrint
    ptGrid.N_Border = 1
    ptGrid.N_Cols = "1,2,3,4,5,6"
    Set ptGrid.N_Grid = lstPro
    ptGrid.N_TiTle = "【菜名列表】"
    ptGrid.N_Head10 = "制表人：" & UserText
    ptGrid.N_Head2 = "制表时间：" & Now
    ptGrid.N_PageLeft = XLeft
    ptGrid.N_PageTop = XTop
    ptGrid.N_PageHeight = 290
    ptGrid.N_PageWidth = 200
    ptGrid.N_RowHeight = 6
    ptGrid.PrintPage
    
    Set ptGrid = Nothing
  
 Exit Sub
Err1:
  MsgBox "对不起,打印列表错误。  " & vbCrLf & vbCrLf & Err.Description, vbInformation
  Exit Sub

End Sub

Private Sub lstPro_DblClick()

  'If lstPro.ListItems.Count = 0 Then Exit Sub
  'If lstPro.SelectedItem.Text = "" Then Exit Sub
  
 '修改该菜单
  'Call cmdModify_Click
  
End Sub

Private Sub lstPro_ItemClick(ByVal Item As MSComctlLib.ListItem)

  If lstPro.ListItems.Count = 0 Then
     cmdDel.Enabled = False: cmdModify.Enabled = False
     Exit Sub
  End If
  If lstPro.SelectedItem.Text = "" Then
     cmdDel.Enabled = False: cmdModify.Enabled = False
     Exit Sub
  End If
  
  cmdDel.Enabled = True: cmdModify.Enabled = True
  
End Sub

Private Sub txtCode_KeyDown(KeyCode As Integer, Shift As Integer)

  DirectFocus txtDW, cmbType, txtCode, txtCode, KeyCode
  
End Sub

Private Sub cmbType_KeyDown(KeyCode As Integer, Shift As Integer)

  DirectFocus txtCode, txtPingYin, cmbType, cmbType, KeyCode

End Sub

Private Sub txtDW_Click()

  AddValid

End Sub

Private Sub txtDW_KeyDown(KeyCode As Integer, Shift As Integer)

 DirectFocus txtDJ, txtCode, txtDW, txtDW, KeyCode

End Sub

Private Sub txtPingYin_KeyDown(KeyCode As Integer, Shift As Integer)
  
  DirectFocus cmbType, cmdAdd, txtPingYin, txtPingYin, KeyCode

End Sub

Private Sub txtPingyin_GotFocus()

  txtPingYin.SelStart = 0
  txtPingYin.SelLength = Len(txtPingYin.Text)
 
End Sub

Private Sub txtPM_Change()

  AddValid
  
 '取消时,给出拼音无效
  If cmdModify.Caption <> "取消" Then
     txtPingYin.Text = GetPy(txtPM.Text)
  End If
  
End Sub

Private Sub txtPM_GotFocus()

  txtPM.SelStart = 0
  txtPM.SelLength = Len(txtPM)
  
End Sub

Private Sub txtPM_KeyDown(KeyCode As Integer, Shift As Integer)

 DirectFocus txtPM, txtDJ, txtPM, txtPM, KeyCode

End Sub


Private Sub Form_Load()

   GetFormSet Me, frmMain
   MenuFocus = True
  
  '刷新预订信息,显示所有预订信息
   frmMain.lbControl.Caption = "菜单配置"
   Screen.MousePointer = 11
   
   sGlobalType = ""
   ConfigType
  '配置菜单列表
   ConfigGrid
    
  '给出菜类型列表+++++++++++++++++++++++++++++++++++++++++
   GetTypeList "MenuType", cmbType
   GetTypeList "UnitType", txtDW
 
   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
  
  Frame1.Width = Me.Width - 400
  Frame2.Width = Frame1.Width
  Frame2.Height = Me.Height - 1100 - Frame1.Height
  Strip1.Width = Frame1.Width - 50
  'cmdClose.Left = Frame1.Width - cmdClose.Width - 200
  lstPro.Width = Frame2.Width - 80
  lstPro.Height = Frame2.Height - 180
  Line1.X2 = lstPro.Width
  
  cmdClose.Left = Me.ScaleWidth - cmdClose.Width - 400
  
End Sub

Private Sub Form_Unload(Cancel As Integer)

  SaveFormSet Me
  MenuFocus = False
  
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 txtDJ_Change()

 AddValid
 If Trim(txtDJ.Text) = "" Then
    txtDJ.Text = "0"
    txtDJ.SelStart = 0
    txtDJ.SelLength = 1
    txtDJ.SetFocus
    Exit Sub
 End If
 If Trim(txtDJ.Text) = "." Then
    txtDJ.Text = "0."
    txtDJ.SelStart = 2
    txtDJ.SelLength = 0
    txtDJ.SetFocus
    Exit Sub
 End If
 
End Sub

Private Sub txtDJ_GotFocus()

  txtDJ.SelStart = 0
  txtDJ.SelLength = Len(txtDJ)
  
End Sub

Private Sub txtDJ_KeyDown(KeyCode As Integer, Shift As Integer)

DirectFocus txtPM, txtDW, txtDJ, txtDJ, KeyCode

End Sub

Private Sub txtDJ_KeyPress(KeyAscii As Integer)

If (KeyAscii > 45 And KeyAscii < 58 And KeyAscii <> 47) Or KeyAscii = 8 Then
   If KeyAscii = 46 And InStr(1, txtDJ, ".", vbBinaryCompare) > 0 Then '为小数点时
      KeyAscii = 0
   End If
      Exit Sub
   Else
   KeyAscii = 0
End If

End Sub

Private Sub txtCode_Change()

 AddValid
  
End Sub

Private Sub txtCode_GotFocus()
  
  txtCode.SelStart = 0
  txtCode.SelLength = Len(txtCode)
  
End Sub

Private Sub Strip1_Click()
  
  '选择类别
   sGlobalType = Strip1.SelectedItem.Key
   If sGlobalType = "ALL" Then sGlobalType = ""
       ConfigGrid
  
End Sub

Private Sub ConfigGrid()

On Error GoTo Err_init

    Dim DB As Connection, EF As Recordset
    Set DB = CreateObject("ADODB.Connection")
        DB.Open Constr
    Set EF = CreateObject("ADODB.Recordset")
        
      If sGlobalType = "" Then
         EF.Open "Select * from EatList Order by MID", DB, adOpenStatic, adLockReadOnly, adCmdText
      Else
         EF.Open "Select * from EatList Where MType='" & sGlobalType & "' Order by MID", DB, adOpenStatic, adLockReadOnly, adCmdText
      End If
        
      lstPro.Visible = False
      lstPro.ListItems.Clear
      
        If Not (EF.EOF And EF.BOF) Then
            Do While Not EF.EOF()
               InsertToMenu lstPro, EF("MID"), EF("MName"), NullValue(EF("PingYin")), EF("MPrice"), NullValue(EF("Munit")), EF("MType")
               EF.MoveNext
            Loop
            cmdDel.Enabled = True
            cmdModify.Enabled = True
         Else
          cmdDel.Enabled = False
          cmdModify.Enabled = False
        End If
        EF.Close
        Set EF = Nothing
        DB.Close
        Set DB = Nothing
        lstPro.Visible = True
        
   Exit Sub
Err_init:
   MsgBox "给出菜单错误:" & Err.Description, vbCritical
 
End Sub

Private Sub InsertToMenu(tmpView As ListView, sText1 As String, sText2 As String, sText3 As String _
      , sText4 As String, sText5 As String, sText6 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)
       lstTmp.SubItems(5) = Trim(sText6)
       
End Sub

Private Sub ConfigType()

   On Error GoTo Err_init
   
   Dim tDB As Connection
   Dim tEf As Recordset, sEXE As String
   Set tDB = CreateObject("ADODB.Connection")
       tDB.Open Constr
       sEXE = "Select Class From MenuType"
   Set tEf = CreateObject("ADODB.Recordset")
       tEf.Open sEXE, tDB, adOpenStatic, adLockReadOnly, adCmdText
     If tEf.EOF And tEf.BOF Then
        Strip1.SelectedItem.Key = "Null"
        sGlobalType = ""
      Else
        Dim x As Integer
            x = 1
        Do While Not tEf.EOF
          '给出菜分类
           Strip1.Tabs.Add x, tEf.Fields(0), tEf.Fields(0) & "&" & Chr(64 + x)
           x = x + 1
           tEf.MoveNext
        Loop
        sGlobalType = Strip1.SelectedItem.Key
     End If
     tEf.Close
     Set tEf = Nothing
     tDB.Close
     Set tDB = Nothing
     Exit Sub
     
Err_init:
    MsgBox "菜分类错误，名称不能全为数字 ？ " & Err.Description, vbExclamation, "错误：0577-86261392 013955647557"

End Sub