frmselectmenu.frm

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

Attribute VB_Name = "frmSelectMenus"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Dim Old_Code As String
Dim sGlobalType As String
Dim sMySql As String         '查询语句

Private Sub cmdClose_Click()

   Unload Me
   
End Sub

Private Sub AddValid()
   
     
End Sub


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


Private Sub cmdPrint_Click()
 
  Dim sTmp As String
  Dim sOR As String
      sOR = " Where "
  If Trim(txtPM.Text) <> "" Then
     sTmp = sTmp & sOR & " MName Like '%" & Trim(txtPM.Text) & "%'"
     sOR = " And "
  End If
  
  If Trim(txtCode.Text) <> "" Then
     sTmp = sTmp & sOR & " MID Like '%" & Trim(txtCode.Text) & "%'"
     sOR = " And "
  End If
  
  If Trim(cmbType.Text) <> "" Then
     sTmp = sTmp & sOR & " MType Like '%" & Trim(cmbType.Text) & "%'"
     sOR = " And "
  End If
  
  If Trim(txtPingYin.Text) <> "" Then
     sTmp = sTmp & sOR & " PingYin Like '%" & Trim(txtPingYin.Text) & "%'"
     sOR = " And "
  End If
    
  If sTmp <> "" Then
     sMySql = sTmp
     sGlobalType = ""
    Else
     sMySql = ""
  End If
  
  Strip1.Tabs.Item(Strip1.Tabs.Count).Selected = True
     
End Sub

Private Sub lstPro_DblClick()

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

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

  DirectFocus txtPM, 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 txtPingYin_KeyDown(KeyCode As Integer, Shift As Integer)
  
  DirectFocus cmbType, cmdPrint, txtPingYin, txtPingYin, KeyCode

End Sub

Private Sub txtPingyin_GotFocus()

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

Private Sub txtPM_Change()

  AddValid
  
  
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, txtCode, txtPM, txtPM, KeyCode

End Sub


Private Sub Form_Load()

   GetFormSet Me, Screen
  
  '刷新预订信息,显示所有预订信息
   frmMain.lbControl.Caption = "菜单配置"
   Screen.MousePointer = 11
   sMenuName = ""
   
   sGlobalType = ""
   ConfigType
  '配置菜单列表
   ConfigGrid
    
  '给出菜类型列表+++++++++++++++++++++++++++++++++++++++++
   GetTypeList "MenuType", cmbType
 
   Screen.MousePointer = 0
  
End Sub

Private Sub Form_Resize()

  On Error Resume Next
  
  If Me.WindowState = 1 Then Exit Sub
  
  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
  
End Sub

Private Sub Form_Unload(Cancel As Integer)

  SaveFormSet Me
  
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 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 " & sMySql & " 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
        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