modfocus.bas

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

        sDel = "Update SiteType Set SiteStatus=1 Where Class In (Select Class From tbdBook Where ExpireDate='" & Date & "' And DatePart=" & tmpDatePart & " And Class='" & stmpSiteID & "')"
        Else
        sDel = "Update SiteType Set SiteStatus=1 Where Class In (Select Class From tbdBook Where ExpireDate=#" & Date & "# And DatePart=" & tmpDatePart & " And Class='" & stmpSiteID & "')"
     End If
     CDB.Execute sDel
     CDB.CommitTrans
     CDB.Close
     Set CDB = Nothing
     CancelMaintenans = True
     
  Exit Function
CancelERR:
  CancelMaintenans = False
  MsgBox "恢复座位状态错误？" & Err.Description, vbCritical
  
End Function

'检查会员是否存在
Public Function CheckCustomer(stmpID As String) As Boolean
  
  On Error GoTo GetERR
  
  Dim CDB As Connection
  Dim CRs As Recordset
  Set CDB = CreateObject("ADODB.Connection")
  Set CRs = CreateObject("ADODB.Recordset")
      CDB.Open Constr
      CRs.Open "Select * from tbdMember Where ID='" & stmpID & "'", CDB, adOpenStatic, adLockReadOnly, adCmdText
      If Not (CRs.EOF And CRs.BOF) Then
         CheckCustomer = True
        Else
         CheckCustomer = False
      End If
      CRs.Close
      CDB.Close
      Set CRs = Nothing
      Set CDB = Nothing
      
      Exit Function
GetERR:
  MsgBox "不能校对会员编号:" & Err.Description, vbCritical
  CheckCustomer = False
  
End Function

'检查会员是否存在
Public Function CheckCustomerRate(stmpID As String) As Boolean
  
  On Error GoTo GetERR
      sGuestID = "": sGuestName = "": cGuestRemain = 0
  Dim CDB As Connection
  Dim CRs As Recordset
  Set CDB = CreateObject("ADODB.Connection")
  Set CRs = CreateObject("ADODB.Recordset")
      CDB.Open Constr
      CRs.Open "Select tbdMember.DLevel,tbdMember.Consume,tbdMember.Name,tbdLevel.DDiscount " _
           & "from tbdMember Inner Join tbdLevel On tbdMember.DLevel=tbdLevel.ID " _
           & " Where tbdMember.ID='" & stmpID & "'", CDB, adOpenStatic, adLockReadOnly, adCmdText
      If Not (CRs.EOF And CRs.BOF) Then
         CheckCustomerRate = True
         cRate = CRs("DDiscount")
         sGuestID = stmpID: sGuestName = CRs("Name")
         cGuestRemain = CRs("Consume")
        Else
         CheckCustomerRate = False
         cRate = 100
      End If
      CRs.Close
      CDB.Close
      Set CRs = Nothing
      Set CDB = Nothing
      
      Exit Function
GetERR:
  MsgBox "不能校对会员编号:" & Err.Description, vbCritical
  CheckCustomerRate = False
  cRate = 100
  
End Function

'检查菜单是否存在
Public Function CheckMenuCat(stmpID As String) As Boolean
  
  On Error GoTo GetERR
  
  Dim CDB As Connection
  Dim CRs As Recordset
  Set CDB = CreateObject("ADODB.Connection")
  Set CRs = CreateObject("ADODB.Recordset")
      CDB.Open Constr
      CRs.Open "Select * from tbdMenuCat Where MenuID='" & stmpID & "'", CDB, adOpenStatic, adLockReadOnly, adCmdText
      If Not (CRs.EOF And CRs.BOF) Then
         CheckMenuCat = True
        Else
         CheckMenuCat = False
      End If
      CRs.Close
      CDB.Close
      Set CRs = Nothing
      Set CDB = Nothing
      
      Exit Function
GetERR:
  MsgBox "不能校对菜单编号:" & Err.Description, vbCritical
  CheckMenuCat = False
  
End Function

'检查座位是否被预订
Public Function CheckSiteIde(stmpID As String) As Boolean
  
  On Error GoTo GetERR
  
  Dim CDB As Connection
  Dim CRs As Recordset
  Set CDB = CreateObject("ADODB.Connection")
  Set CRs = CreateObject("ADODB.Recordset")
      CDB.Open Constr
      CRs.Open "Select * from SiteType Where SiteStatus=0 And Class='" & stmpID & "'", CDB, adOpenStatic, adLockReadOnly, adCmdText
      If Not (CRs.EOF And CRs.BOF) Then
         CheckSiteIde = True
        Else
         CheckSiteIde = False
      End If
      CRs.Close
      CDB.Close
      Set CRs = Nothing
      Set CDB = Nothing
      
      Exit Function
GetERR:
  MsgBox "不能检查座位状态:" & Err.Description, vbCritical
  CheckSiteIde = False
  
End Function

Public Sub GetTypeList(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
             tmpList.AddItem utRS("Class")
             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

Public Sub GetEmployList(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 "tbdGuest", utDB, adOpenStatic, adLockReadOnly, adCmdTable
       If Not (utRS.EOF And utRS.BOF) Then
          Do While Not utRS.EOF
             tmpList.AddItem utRS("DName")
             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

Public Sub GetMenuTypeList(sTable As String, tmpList As Object)
  
   On Error GoTo GetERR
   
   tmpList.Clear
   
   Dim utDB As Connection
   Dim utRS As Recordset
   Dim lLen As Integer
   
   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
             lLen = LenB(StrConv(utRS("Class"), vbFromUnicode))
             If utRS("Discount") = 0 Then
                tmpList.AddItem utRS("Class") & Space(30 - lLen) & "禁止打折"
               Else
                tmpList.AddItem utRS("Class") & Space(30 - lLen) & "统一打折"
             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

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

'删除餐桌类型
Public Function DeleteSiteType(sName As String, sTable As String) As Boolean
  
   On Error GoTo GetERR
   
   Dim utDB As Connection
   Set utDB = CreateObject("ADODB.Connection")
       utDB.Open Constr
   Dim usRs As Recordset
   Set usRs = CreateObject("ADODB.Recordset")
       usRs.Open "Select * from SiteType Where  Class='" & sName & "'", utDB, adOpenStatic, adLockReadOnly, adCmdText
       If usRs.EOF And usRs.BOF Then
          usRs.Close
          utDB.Close
          Set usRs = Nothing
          Set utDB = Nothing
          DeleteSiteType = True
          Exit Function
         Else
             If usRs("SiteStatus") > 0 Then
                usRs.Close
                utDB.Close
                Set usRs = Nothing
                Set utDB = Nothing
                DeleteSiteType = False
                MsgBox "很抱歉,该餐桌已经预订或上台,暂不能删除？  ", vbInformation
                Exit Function
              End If
       End If
       usRs.Close
       utDB.Execute "Delete From " & sTable & " Where Class='" & sName & "'"
       utDB.Close
       Set usRs = Nothing
       Set utDB = Nothing
       DeleteSiteType = True
       
   Exit Function
GetERR:
   DeleteSiteType = False
   MsgBox "删除错误:" & Err.Description, vbCritical
   
End Function

'删除类型
Public Function DeleteMenuType(sName As String, sTable As String) As Boolean
  
   On Error GoTo GetERR
   If InStr(1, sName, " ", vbTextCompare) > 0 Then
      sName = Left(sName, InStr(1, sName, " ", vbTextCompare) - 1)
   End If
   Dim utDB As Connection
   Set utDB = CreateObject("ADODB.Connection")
       utDB.Open Constr
       utDB.Execute "Delete From " & sTable & " Where Class='" & sName & "'"
       utDB.Close
       Set utDB = Nothing
       DeleteMenuType = True
       
   Exit Function
GetERR:
   DeleteMenuType = False
   MsgBox "删除错误:" & Err.Description, vbCritical
   
End Function

'删除类型
Public Function DeleteMenuCat(sName As String, sTable As String) As Boolean
  
   On Error GoTo GetERR
   
   Dim utDB As Connection
   Set utDB = CreateObject("ADODB.Connection")
       utDB.Open Constr
       utDB.BeginTrans
      '删除酒席
       utDB.Execute "Delete From tbdMenuCat Where MenuID='" & sName & "'"
      '删除酒席列表
       utDB.Execute "Delete From tbdMenuCatDetail Where MenuID='" & sName & "'"
       utDB.CommitTrans
       utDB.Close
       Set utDB = Nothing
       DeleteMenuCat = True
       
   Exit Function
GetERR:
   DeleteMenuCat = False
   MsgBox "删除错误:" & Err.Description, vbCritical
   
End Function

'删除类型
Public Function DeleteMenuCatDetail(sName As String, sIDs As String, sTable As String) As Boolean
  
   On Error GoTo GetERR
   
   Dim utDB As Connection
   Set utDB = CreateObject("ADODB.Connection")
       utDB.Open Constr
      '删除酒席列表,酒席为sIDs,sName为菜单编号
       utDB.Execute "Delete From tbdMenuCatDetail Where MenuID='" & sIDs & "' And MenuName='" & sName & "'"
       utDB.Close
       Set utDB = Nothing
       DeleteMenuCatDetail = True
       
   Exit Function
GetERR:
   DeleteMenuCatDetail = False
   MsgBox "删除错误:" & Err.Description, vbCritical
   
End Function

'给出菜的名称
Public Function GetProName(sIDs As String) As String
  
   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 "Select * from EatList Where MID='" & sIDs & "'", utDB, adOpenStatic, adLockReadOnly, adCmdText
       If utRS.EOF And utRS.BOF Then
          GetProName = ""
         Else
          GetProName = utRS("MName")
       End If
       utRS.Close
       utDB.Close
       Set utRS = Nothing
       Set utDB = Nothing
       
   Exit Function
GetERR:
   GetProName = ""
   MsgBox "给出产品名称错误:" & Err.Description, vbCritical
   
End Function

Public Function GetCode(sWP As String, sFields As String, sTable As String) As Boolean

   On Error GoTo Err_init
   Dim tDB As Connection