frmbase.frm

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

GetERR:
   AddSiteType = False
   MsgBox "添加错误:" & Err.Description, vbCritical
   
End Function

'给出包厢列表
Private Sub GetSiteTypeList(sTable As String, tmpList As ListBox)
  
   On Error GoTo GetERR
   
   tmpList.Clear
   
   Dim lLen As Integer
          
   Dim utDB As Connection
   Dim utRS As Recordset
   Set utDB = CreateObject("ADODB.Connection")
   Set utRS = CreateObject("ADODB.Recordset")
       utDB.Open Constr
       utRS.Open sTable, utDB, adOpenStatic, adLockReadOnly, adCmdTable
       If Not (utRS.EOF And utRS.BOF) Then
          Do While Not utRS.EOF
             tmpList.AddItem utRS("Class") & Space(4) & utRS("Price") & Space(4) & utRS("supperPrice") & Space(4) & utRS("nightPrice")
             utRS.MoveNext
          Loop
          If tmpList.ListCount > 0 Then
             tmpList.ListIndex = 0
          End If
       End If
       utRS.Close
       utDB.Close
       Set utRS = Nothing
       Set utDB = Nothing
   
   Exit Sub
GetERR:
   MsgBox "给出错误:" & Err.Description, vbCritical
   
End Sub

Private Sub cmdModifyMenu_Click()

 On Error GoTo ModifyERR
 
 If lstMenu.ListCount <= 0 Then
    MsgBox "没有项目可以修改？   ", vbExclamation
    Exit Sub
 End If
 
 If lstMenu.Text = "" Then
    MsgBox "请选择项目后,再按【修改】按钮。  ", vbExclamation
    Exit Sub
 End If
 
 Dim sTMp As String

 If cmdModifyMenu.Caption = "修改" Then
    '保存按钮无效,删除按钮变为取消，修改变为保存(&S)
     cmdDelMenu.Caption = "取消"
     cmdModifyMenu.Caption = "保存"
     cmdAddMenu.Enabled = False
     '1首先给出其名称
      sTMp = Left(lstMenu.Text, InStr(1, lstMenu.Text, Space(4), vbTextCompare) - 1)
      ftMenu.Text = sTMp
      If Trim(Right(lstMenu.Text, 4)) = "禁止打折" Then
         cmbDiscount.ListIndex = 0
        Else
         cmbDiscount.ListIndex = 1
      End If
      lstMenu.Enabled = False
      ftMenu.SetFocus
   Else
    '保存时
    '1修改数据库中项目,给出原始名称
      lstMenu.Enabled = True
      sTMp = lstMenu.Text
      sTMp = Left(lstMenu.Text, InStr(1, lstMenu.Text, Space(4), vbTextCompare) - 1)
      If EditMenuType(Trim(ftMenu.Text), sTMp, "Select * from MenuType Where Class='" & sTMp & "'", cmbDiscount.ListIndex) = True Then
          '2更新列表中内容
            GetTypeBaseList "MenuType", lstMenu
      End If
     '恢复数据
      cmdDelMenu.Caption = "删除"
      cmdModifyMenu.Caption = "修改"
      cmdAddMenu.Enabled = True
      lstMenu.Enabled = True
      ftMenu.Text = ""
      ftMenu.SetFocus
 End If
 
 Exit Sub
ModifyERR:
 MsgBox "修改数据错误:" & Err.Description, vbCritical
 Exit Sub
 
End Sub


Private Sub cmdModifySite_Click()
 
 On Error GoTo ModifyERR
 
 Dim sTMp As String
 Dim xTmp As Integer
 
 If lstSite.ListCount <= 0 Then
    MsgBox "没有项目可以修改？   ", vbExclamation
    Exit Sub
 End If
 
 If lstSite.Text = "" Then
    MsgBox "请选择项目后,再按【修改】按钮。  ", vbExclamation
    Exit Sub
 End If
 
 If cmdModifySite.Caption = "修改" Then
    '保存按钮无效,删除按钮变为取消，修改变为保存(&S)
     cmdDelSite.Caption = "取消"
     cmdModifySite.Caption = "保存"
     cmdAddSite.Enabled = False
    '1首先给出其名称
     sTMp = lstSite.Text
     Dim tmpListSite() As String
         tmpListSite = Split(sTMp, Space(4))
      ftSite.Text = tmpListSite(0)                     '座位名称
      ftPrice.Text = tmpListSite(1)                    '中午包厢费
      ftSupperPrice.Text = tmpListSite(2)              '下午包厢费
      ftNightPrice.Text = tmpListSite(3)               '晚上包厢费
      lstSite.Enabled = False
      ftSite.SetFocus
   Else
    '保存时
    '1修改数据库中项目,给出原始名称
      lstSite.Enabled = True
      sTMp = lstSite.Text
      tmpListSite = Split(sTMp, Space(4))
      sTMp = tmpListSite(0)                    '座位名称
      If EditSiteType(Trim(ftSite.Text), sTMp, "Select * from SiteType Where Class='" & sTMp & "'", CCur(ftPrice.Text), CCur(ftSupperPrice.Text), CCur(ftNightPrice.Text)) = True Then
        '2更新列表中内容
         GetSiteTypeList "SiteType", lstSite
      End If
     '恢复数据
      cmdDelSite.Caption = "删除"
      cmdModifySite.Caption = "修改"
      cmdAddSite.Enabled = True
     '1首先给出其名称
      ftSite.Text = ""
      lstSite.Enabled = True
      ftPrice.Text = "0"
      ftSupperPrice.Text = "0"
      ftNightPrice.Text = "0"
      ftSite.SetFocus
      Exit Sub
 End If
 
 Exit Sub
ModifyERR:
 MsgBox "修改数据错误:" & Err.Description, vbCritical
 Exit Sub
End Sub

Private Sub Form_Load()

  GetFormSet Me, frmMain
  BaseFocus = True
  
  On Error Resume Next
    
  Screen.MousePointer = 11
  
  frmMain.lbControl.Caption = "基本项目配置"
  cmbDiscount.ListIndex = 0
  
 '给出单位配置列表 ++++++++++++++++++++++++++++++++++++
  GetTypeList "UnitType", lstUnitType
   If lstUnitType.ListCount = 0 Then
     cmdDelUnit.Enabled = False
    Else
     cmdDelUnit.Enabled = True
  End If
 '给出付款类型列表+++++++++++++++++++++++++++++++++++++++++
  GetTypeList "PayType", lstPayment
   If lstPayment.ListCount = 0 Then
     cmdDeletePayment.Enabled = False
    Else
     cmdDeletePayment.Enabled = True
  End If
 '给出菜类型列表+++++++++++++++++++++++++++++++++++++++++
  GetTypeBaseList "MenuType", lstMenu
    If lstMenu.ListCount = 0 Then
       cmdDelMenu.Enabled = False
     Else
       cmdDelMenu.Enabled = True
    End If
 '给出座位类型列表+++++++++++++++++++++++++++++++++++++++++
  GetSiteTypeList "SiteType", lstSite
   If lstSite.ListCount = 0 Then
     cmdDelSite.Enabled = False
    Else
     cmdDelSite.Enabled = True
  End If

  Screen.MousePointer = 0
  
End Sub

Private Sub GetTypeBaseList(sTable As String, tmpList As Object)
  
   On Error GoTo GetERR
   
   tmpList.Clear
   
   Dim utDB As Connection
   Dim utRS As Recordset
   Set utDB = CreateObject("ADODB.Connection")
   Set utRS = CreateObject("ADODB.Recordset")
       utDB.Open Constr
       utRS.Open sTable, utDB, adOpenStatic, adLockReadOnly, adCmdTable
       If Not (utRS.EOF And utRS.BOF) Then
          Do While Not utRS.EOF
             If utRS("Discount") = 0 Then
                tmpList.AddItem utRS("Class") & Space(4) & "禁止打折"
               Else
                tmpList.AddItem utRS("Class") & Space(4) & "允许打折"
             End If
             utRS.MoveNext
          Loop
       End If
       utRS.Close
       utDB.Close
       Set utRS = Nothing
       Set utDB = Nothing
       
   If tmpList.ListCount > 0 Then
      tmpList.ListIndex = 0
   End If
   
   Exit Sub
GetERR:
   MsgBox "给出错误:" & Err.Description, vbCritical
   
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
  
End Sub

Private Sub Form_Unload(Cancel As Integer)

  SaveFormSet Me
  frmMain.lbControl.Caption = "收银控制中心"
  BaseFocus = False
  
End Sub



Private Sub ftNightPrice_Change()

  If ftNightPrice.Text = "" Then
     ftNightPrice.Text = "0"
     ftNightPrice.SelStart = 0
     ftNightPrice.SelLength = 1
     Exit Sub
  End If
  If ftNightPrice.Text = "." Then
     ftNightPrice.Text = "0."
     ftNightPrice.SelStart = 2
     ftNightPrice.SelLength = 0
     Exit Sub
  End If

End Sub

Private Sub ftPayment_KeyPress(KeyAscii As Integer)

  If KeyAscii = 13 And Trim(ftPayment.Text) <> "" Then
     Call cmdAddPayment_Click
  End If
  
End Sub

Private Sub ftPrice_Change()

  If ftPrice.Text = "" Then
     ftPrice.Text = "0"
     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 ftPrice_KeyPress(KeyAscii As Integer)

  If KeyAscii = 13 And Trim(ftSite.Text) <> "" Then
     Call cmdAddSite_Click
  End If
  
End Sub

Private Sub ftPrice_LostFocus()

  If IsNumeric(ftPrice.Text) = False Then
     ftPrice.Text = "0"
  End If
  
End Sub

Private Sub ftSupperPrice_Change()

  If ftSupperPrice.Text = "" Then
     ftSupperPrice.Text = "0"
     ftSupperPrice.SelStart = 0
     ftSupperPrice.SelLength = 1
     Exit Sub
  End If
  If ftSupperPrice.Text = "." Then
     ftSupperPrice.Text = "0."
     ftSupperPrice.SelStart = 2
     ftSupperPrice.SelLength = 0
     Exit Sub
  End If

End Sub

Private Sub ftUnitType_KeyPress(KeyAscii As Integer)

  If KeyAscii = 13 And Trim(ftUnitType.Text) <> "" Then
     Call cmdAddUnit_Click
  End If
  
End Sub


Private Sub lstMenu_Click()
  
  If lstMenu.ListCount = 0 Then
     cmdDelMenu.Enabled = False
     cmdModifyMenu.Enabled = False
    Else
     If lstMenu.Text = "" Then Exit Sub
        cmdDelMenu.Enabled = True
        cmdModifyMenu.Enabled = True
  End If

End Sub

Private Sub lstMenu_DblClick()

  If lstMenu.ListCount > 0 Then
     If lstMenu.Text <> "" Then
        Call cmdModifyMenu_Click
     End If
  End If
  
End Sub


Private Sub lstPayment_Click()

  If lstPayment.ListCount = 0 Then
     cmdDeletePayment.Enabled = False
    Else
     If lstPayment.Text = "" Then Exit Sub
        cmdDeletePayment.Enabled = True
  End If

End Sub

Private Sub lstSite_Click()

  If lstSite.ListCount = 0 Then
     cmdDelSite.Enabled = False
     cmdModifySite.Enabled = False
    Else
     If lstSite.Text <> "" Then
        cmdModifySite.Enabled = True
        cmdDelSite.Enabled = True
      Else
        cmdDelSite.Enabled = False