frmbase.frm

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

  Exit Sub
DelErr:
  MsgBox "删除错误:" & Err.Description, vbCritical
  Exit Sub
End Sub


Private Sub cmdDelSite_Click()
  
  On Error GoTo DelErr
  
  If cmdDelSite.Caption = "取消" Then
     cmdDelSite.Caption = "删除"
     cmdModifySite.Caption = "修改"
     cmdAddSite.Enabled = True
    '1首先给出其名称
      ftSite.Text = ""
      lstSite.Enabled = True
      ftPrice.Text = "0"
      ftSite.SetFocus
      Exit Sub
  End If
  
  If lstSite.ListCount = 0 Then Exit Sub
  If lstSite.Text = "" Then
     MsgBox "请选择需要座位（餐桌）,再删除。  ", vbInformation
     lstSite.ListIndex = 0
     lstSite.SetFocus
     Exit Sub
  End If
  
  If MsgBox("真的要删除〖" & Trim(Mid(lstSite.Text, 1, InStr(1, lstSite, " ", vbTextCompare) - 1)) & "〗座位（餐桌）吗？(Y/N)    ", vbYesNo + vbInformation) = vbNo Then Exit Sub
  
  If DeleteSiteType(Trim(Mid(lstSite.Text, 1, InStr(1, lstSite, " ", vbTextCompare) - 1)), "SiteType") = True Then
     lstSite.RemoveItem lstSite.ListIndex
  End If
  
  If lstSite.ListCount = 0 Then
     cmdDelSite.Enabled = False
    Else
     cmdDelSite.Enabled = True
  End If
  
  ftSite.SetFocus
  
  Exit Sub
DelErr:
  MsgBox "删除错误:" & Err.Description, vbCritical
  Exit Sub
End Sub

Private Sub cmdDelUnit_Click()

  On Error Resume Next
  
  If lstUnitType.ListCount = 0 Then Exit Sub
  If lstUnitType.Text = "" Then
     MsgBox "请选择需要类型,再删除。  ", vbInformation
     lstUnitType.ListIndex = 0
     lstUnitType.SetFocus
     Exit Sub
  End If
  
  If MsgBox("真的要删除〖" & lstUnitType.Text & "〗类型吗？(Y/N)    ", vbYesNo + vbInformation) = vbNo Then Exit Sub
  
  If DeleteType(lstUnitType.Text, "Unittype") = True Then
     lstUnitType.RemoveItem lstUnitType.ListIndex
  End If
  
  If lstUnitType.ListCount = 0 Then
     cmdDelUnit.Enabled = False
    Else
     cmdDelUnit.Enabled = True
  End If
  
  ftUnitType.SetFocus
  
End Sub

Private Function AddMenuType(sName As String, sSQL As String, iDiscount As Integer) As Boolean
  
   On Error GoTo GetERR
   
   Dim utDB As Connection
   Dim utRS As Recordset
   Set utDB = CreateObject("ADODB.Connection")
   Set utRS = CreateObject("ADODB.Recordset")
       utDB.Open Constr
      '首先查询是否有重复
       utRS.Open sSQL, utDB, adOpenStatic, adLockOptimistic, adCmdText
       If Not (utRS.EOF And utRS.BOF) Then
          AddMenuType = False
          MsgBox "对不起,类型【" & sName & "】已经存在,修改后继续？  ", vbExclamation
         Else
          utRS.AddNew
          utRS("CLass") = sName
          utRS("Discount") = iDiscount            '菜单打折状态
          utRS.Update
          AddMenuType = True
       End If
       utRS.Close
       utDB.Close
       Set utRS = Nothing
       Set utDB = Nothing
       
   Exit Function
GetERR:
   AddMenuType = False
   MsgBox "添加错误:" & Err.Description, vbCritical
   
End Function

Private Function AddType(sName As String, sSQL As String) As Boolean
  
   On Error GoTo GetERR
   
   Dim utDB As Connection
   Dim utRS As Recordset
   Set utDB = CreateObject("ADODB.Connection")
   Set utRS = CreateObject("ADODB.Recordset")
       utDB.Open Constr
      '首先查询是否有重复
       utRS.Open sSQL, utDB, adOpenStatic, adLockOptimistic, adCmdText
       If Not (utRS.EOF And utRS.BOF) Then
          AddType = False
          MsgBox "对不起,类型【" & sName & "】已经存在,修改后继续？  ", vbExclamation
         Else
          utRS.AddNew
          utRS("CLass") = sName
          utRS.Update
          AddType = True
       End If
       utRS.Close
       utDB.Close
       Set utRS = Nothing
       Set utDB = Nothing
       
   Exit Function
GetERR:
   AddType = False
   MsgBox "添加错误:" & Err.Description, vbCritical
   
End Function

Private Function EditMenuType(sName As String, sOldName As String, sSQL As String, lDiscount As Integer) As Boolean
  
   On Error GoTo GetERR
   
  'SQL中包含原来的类型
   Dim utDB As Connection
   Dim utRS As Recordset
   
   Set utDB = CreateObject("ADODB.Connection")
   Set utRS = CreateObject("ADODB.Recordset")
   
       utDB.Open Constr
       utDB.BeginTrans
      '首先查询是否有重复
       If UCase(sName) <> UCase(sOldName) Then
          Dim dtRs As Recordset
          Set dtRs = CreateObject("ADODB.Recordset")
              dtRs.Open "Select * from MenuType Where Class='" & sName & "'", utDB, adOpenStatic, adLockReadOnly, adCmdText
             '该编号已经存在时
              If Not (dtRs.EOF And dtRs.BOF) Then
                 utDB.RollbackTrans
                 dtRs.Close
                 Set dtRs = Nothing
                 utDB.Close
                 Set utDB = Nothing
                 EditMenuType = False
                 MsgBox "对不起,【" & sName & "】已经存在，修改后继续？  ", vbExclamation
                 Exit Function
              End If
             '一切正常
              dtRs.Close
              Set dtRs = Nothing
       End If
       utRS.Open sSQL, utDB, adOpenStatic, adLockOptimistic, adCmdText
       If utRS.EOF And utRS.BOF Then
          EditMenuType = False
          utDB.RollbackTrans
          MsgBox "对不起,【" & sOldName & "】不存在,修改错误？  ", vbExclamation
         Else
          utRS("Class") = sName
          utRS("Discount") = lDiscount
          utRS.Update
         '修改其它单据的ID
          Dim sMy As String
              sMy = "Update EatList Set MType='" & sName & "' Where MType='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update Cust Set DType='" & sName & "' Where DType='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update prtCust Set DType='" & sName & "' Where DType='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update ptCust Set DType='" & sName & "' Where DType='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update tmpBox Set DType='" & sName & "' Where DType='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update TodayCust Set DType='" & sName & "' Where DType='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update tmpCust Set DType='" & sName & "' Where DType='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update tmpCust1 Set DType='" & sName & "' Where DType='" & sOldName & "'"
              utDB.Execute sMy
          utDB.CommitTrans
          EditMenuType = True
       End If
       utRS.Close
       utDB.Close
       Set utRS = Nothing
       Set utDB = Nothing
       
   Exit Function
GetERR:
   EditMenuType = False
   MsgBox "保存菜单类型错误:" & Err.Description, vbCritical
   
End Function

Private Function EditType(sName As String, sOldName As String, sSQL As String, lDiscount As Integer) As Boolean
  
   On Error GoTo GetERR
   
  'SQL中包含原来的类型
   Dim utDB As Connection
   Dim utRS As Recordset
   
   Set utDB = CreateObject("ADODB.Connection")
   Set utRS = CreateObject("ADODB.Recordset")
   
       utDB.Open Constr
       utDB.BeginTrans
      '首先查询是否有重复
       If UCase(sName) <> UCase(sOldName) Then
          Dim dtRs As Recordset
          Set dtRs = CreateObject("ADODB.Recordset")
              dtRs.Open "Select * from MenuType Where Class='" & sName & "'", utDB, adOpenStatic, adLockReadOnly, adCmdText
             '该编号已经存在时
              If Not (dtRs.EOF And dtRs.BOF) Then
                 utDB.RollbackTrans
                 dtRs.Close
                 Set dtRs = Nothing
                 utDB.Close
                 Set utDB = Nothing
                 EditType = False
                 MsgBox "对不起,【" & sName & "】已经存在，修改后继续？  ", vbExclamation
                 Exit Function
              End If
             '一切正常
              dtRs.Close
              Set dtRs = Nothing
       End If
       
       utRS.Open sSQL, utDB, adOpenStatic, adLockOptimistic, adCmdText
       If utRS.EOF And utRS.BOF Then
          EditType = False
          utDB.RollbackTrans
          MsgBox "对不起,【" & sOldName & "】不存在,修改错误？  ", vbExclamation
         Else
          utRS("CLass") = sName
          utRS("Discount") = lDiscount
          utRS.Update
         '修改其它单据的ID
          Dim sMy As String
              sMy = "Update EatList Set MType='" & sName & "' Where MType='" & sOldName & "'"
              utDB.Execute sMy
              
          utDB.CommitTrans
          EditType = True
       End If
       utRS.Close
       utDB.Close
       Set utRS = Nothing
       Set utDB = Nothing
       
   Exit Function
GetERR:
   EditType = False
   MsgBox "保存错误:" & Err.Description, vbCritical
   
End Function

Private Function EditSiteType(sName As String, sOldName As String, sSQL As String, lDiscount As Currency, lSupper As Currency, lNight As Currency) As Boolean
  
   On Error GoTo GetERR
   
  'SQL中包含原来的类型
   Dim utDB As Connection
   Dim utRS As Recordset
   
   Set utDB = CreateObject("ADODB.Connection")
   Set utRS = CreateObject("ADODB.Recordset")
   
       utDB.Open Constr
       utDB.BeginTrans
      '首先查询是否有重复
       If UCase(sName) <> UCase(sOldName) Then
          Dim dtRs As Recordset
          Set dtRs = CreateObject("ADODB.Recordset")
              dtRs.Open "Select * from SiteType Where Class='" & sName & "'", utDB, adOpenStatic, adLockReadOnly, adCmdText
             '该编号已经存在时
              If Not (dtRs.EOF And dtRs.BOF) Then
                 utDB.RollbackTrans
                 dtRs.Close
                 Set dtRs = Nothing
                 utDB.Close
                 Set utDB = Nothing
                 EditSiteType = False
                 MsgBox "对不起,【" & sName & "】已经存在，修改后继续？  ", vbExclamation
                 Exit Function
              End If
             '一切正常
              dtRs.Close
              Set dtRs = Nothing
       End If
       utRS.Open sSQL, utDB, adOpenStatic, adLockOptimistic, adCmdText
       If utRS.EOF And utRS.BOF Then
          EditSiteType = False
          utDB.RollbackTrans
          MsgBox "对不起,【" & sOldName & "】不存在,修改错误？  ", vbExclamation
         Else
          If utRS("SiteStatus") = 2 Then
             utDB.RollbackTrans
             utRS.Close
             Set utRS = Nothing
             utDB.Close
             Set utDB = Nothing
             EditSiteType = False
             MsgBox "【" & sName & "】正在上台,不能修改。请在结帐后再修改？  ", vbExclamation
             Exit Function
          End If
          utRS("CLass") = sName
          utRS("Price") = lDiscount          '中午包厢费
          utRS("SupperPrice") = lSupper      '下午包厢费
          utRS("NightPrice") = lNight        '晚上包厢费
          utRS.Update
         '修改其它单据的ID
          Dim sMy As String
              sMy = "Update Cust Set Site='" & sName & "' Where Site='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update GatherTodayCust Set Site='" & sName & "' Where Site='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update prtCust Set Site='" & sName & "' Where Site='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update Site Set Site='" & sName & "' Where Site='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update tbdBook Set Class='" & sName & "' Where Class='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update tmpCust Set Site='" & sName & "' Where Site='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update tmpSite Set Site='" & sName & "' Where Site='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update tmpTodayCust Set Site='" & sName & "' Where Site='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update TodayCust Set Site='" & sName & "' Where Site='" & sOldName & "'"
              utDB.Execute sMy
              sMy = "Update TodayCustx Set Site='" & sName & "' Where Site='" & sOldName & "'"
              utDB.Execute sMy
          utDB.CommitTrans
          EditSiteType = True
       End If
       utRS.Close
       utDB.Close
       Set utRS = Nothing
       Set utDB = Nothing
       
   Exit Function
GetERR:
   EditSiteType = False
   MsgBox "保存错误:" & Err.Description, vbCritical
   
End Function

Private Function AddSiteType(sName As String, sPrice As String, SupperPrice As String, NightPrice As String, sSQL As String) As Boolean
  
   On Error GoTo GetERR
   
   Dim utDB As Connection
   Dim utRS As Recordset
   Set utDB = CreateObject("ADODB.Connection")
   Set utRS = CreateObject("ADODB.Recordset")
       utDB.Open Constr
      '首先查询是否有重复
       utRS.Open sSQL, utDB, adOpenStatic, adLockOptimistic, adCmdText
       If Not (utRS.EOF And utRS.BOF) Then
          AddSiteType = False
          MsgBox "对不起,餐桌名称【" & sName & "】已经存在,修改后继续？  ", vbExclamation
         Else
          utRS.AddNew
          utRS("CLass") = sName
          utRS("Price") = CCur(sPrice)                   '中午包厢费
          utRS("SupperPrice") = CCur(SupperPrice)        '下午包厢费
          utRS("NightPrice") = CCur(NightPrice)          '晚上包厢费
          utRS("SiteStatus") = 0
          utRS.Update
          AddSiteType = True
       End If
       utRS.Close
       utDB.Close
       Set utRS = Nothing
       Set utDB = Nothing
       
   Exit Function