modfocus.bas

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

   Dim tEf As Recordset
   Dim sEXE As String
   
   Set tDB = CreateObject("ADODB.Connection")
       tDB.Open Constr
     ' SQL语言删除
      sEXE = "Select * From " & sTable & " Where " & sFields & "='" & sWP & "'"
   Set tEf = CreateObject("ADODB.Recordset")
       tEf.Open sEXE, tDB, adOpenStatic, adLockReadOnly, adCmdText
     If tEf.EOF And tEf.BOF Then
        GetCode = True
      Else
        GetCode = False
     End If
     tEf.Close
     tDB.Close
     Set tEf = Nothing
     Set tDB = Nothing
     Exit Function
     
Err_init:
 MsgBox "查询记录错误:" & vbCrLf & vbCrLf & Err.Description, vbCritical
 GetCode = False
 
End Function

'给出服务员
Public Function GetWaiter(stmpSite As String) As String
  
   On Error GoTo BBERR
   
   Dim wDB As Connection
   Dim wEf As Recordset
   Dim sTMp As String, sWaiter As String
       Screen.MousePointer = 11
   Set wDB = CreateObject("AdODb.Connection")
       wDB.Open Constr
   Set wEf = CreateObject("ADODB.Recordset")
       sTMp = "Select * from tmpSite Where Site='" & stmpSite & "'"
       wEf.Open sTMp, wDB, adOpenStatic, adLockOptimistic, adCmdText
       If wEf.EOF And wEf.BOF Then  '查找到时不管
          GetWaiter = ""
          wEf.Close
          wDB.Close
          Set wEf = Nothing
          Set wDB = Nothing
         Else
          GetWaiter = NullValue(wEf.Fields("Waiter"))
          wEf.Close
          wDB.Close
          Set wEf = Nothing
          Set wDB = Nothing
       End If
       Screen.MousePointer = 0

       Exit Function
BBERR:
    Screen.MousePointer = 0
    GetWaiter = ""
    MsgBox "给出服务员错误:" & Err.Description, vbCritical
End Function

'删除点菜内容
Public Function DeleteTopMenu(nID As Long) As Boolean
  
   On Error GoTo GetERR
   
   Dim utDB As Connection
   Dim FB As Recordset
   Dim EF As Recordset
   Set utDB = CreateObject("ADODB.Connection")
   Set EF = CreateObject("ADODB.Recordset")
   Set FB = CreateObject("ADODB.Recordset")
       
       utDB.Open Constr
       utDB.BeginTrans
       EF.Open "select * from tmpCust Where ID=" & nID, utDB, adOpenStatic, adLockOptimistic, adCmdText
       FB.Open "select * from ptCust", utDB, adOpenStatic, adLockOptimistic, adCmdText
       If Not (EF.EOF And EF.BOF) Then
        '插入飞单机中，数量为负。
        '添加飞单机中==================================================================
         Dim fldSite, fldName, fldCID, fldPingyin, fldUnit As String
         Dim fldPrice, fldQuanty, fldJGF, fldAmo, fldAmos As Currency
         Dim fldType As String
         fldSite = EF("Site")
         fldName = EF("Name")
         fldCID = EF("CID")
         fldPingyin = NullValue(EF("Pingyin"))
         fldUnit = NullValue(EF("Unit")): fldType = NullValue(EF("DType"))
         fldPrice = EF("Price"): fldQuanty = -(EF("Quanty")): fldAmo = EF("Amo"): fldAmos = EF("Amos"): fldJGF = EF("JGF")
        '删除退菜
         EF.Close
         utDB.Execute "Delete From tmpCust Where ID=" & nID
         FB.AddNew
         FB.Fields("ID") = nID
         FB.Fields("Site") = fldSite
         FB.Fields("Name") = fldName
         FB.Fields("CID") = fldCID
         FB.Fields("Pingyin") = fldPingyin
         FB.Fields("Unit") = fldUnit
         FB.Fields("Price") = fldPrice
         FB.Fields("Quanty") = fldQuanty
         FB.Fields("JGF") = fldJGF
         FB.Fields("Amo") = fldAmo
         FB.Fields("Amos") = fldAmos
         FB.Fields("DType") = fldType
         FB.Fields("AtTime") = Time
         FB.Fields("DOper") = UserText
         FB.Update
         FB.Close
        Else
         EF.Close
         FB.Close
        '删除退菜
         utDB.Execute "Delete From tmpCust Where ID=" & nID
       End If
       utDB.CommitTrans
       utDB.Close
       Set EF = Nothing
       Set FB = Nothing
       Set utDB = Nothing
       DeleteTopMenu = True
       
   Exit Function
GetERR:
   DeleteTopMenu = False
   MsgBox "删除上菜错误:" & Err.Description, vbCritical
   
End Function

Public Sub InserToCash(DBTmp As Connection, intDirect As Integer, sMemo As String, curMoney As Currency, bDate As Date, sPaymethod As String)

 '例如：InserToCash SaveDB, 1, "【销售收入】", CCur(ftAmount.Text), Date,"挂帐"
  On Error GoTo AddERR
 'dbTmp 数据库,intDirect为支出与收入,sMemo摘要,curMoney金额,bDate日期
  Dim CB As Recordset
  Set CB = CreateObject("ADODB.Recordset")
      CB.Open "Select * from tbdWastebook", DBTmp, adOpenStatic, adLockOptimistic, adCmdText
      CB.AddNew
      CB("ID") = GetFixNo("流水帐号")
      CB("DReason") = sMemo
      CB("DDate") = bDate
      CB("DMoney") = curMoney
      CB("DDirect") = intDirect '0为支出,1为注入
      CB("DOperator") = UserText
      CB("lHour") = Hour(Time)
      CB("lMinute") = Minute(Time)
      CB("tmpStr") = sPaymethod
      CB.Update
      CB.Close
      
   Exit Sub
AddERR:
   MsgBox "添加流水帐错误:" & Err.Description, vbCritical
   
End Sub

'插入到卡中
Public Sub InserToCard(DBTmp As Connection, intDirect As Integer, sMemo As String, curMoney As Currency, sMID As String, nSiteID As Long, SumMoney As Currency)

  On Error GoTo AddERR
 'dbTmp 数据库,intDirect为充值与消费，CurMoney为金额,sMID为卡号,nSiteID为消费记录号,SumMoney为最后金额
  Dim CB As Recordset
  Set CB = CreateObject("ADODB.Recordset")
      CB.Open "Select * from tbdMemberDetail", DBTmp, adOpenStatic, adLockOptimistic, adCmdText
      CB.AddNew
      CB("MyID") = GetFixNo("卡消费流水号")
      CB("Date") = Date
      CB("lHour") = Hour(Time)
      CB("lMinute") = Minute(Time)
      CB("Oper") = UserText
      CB("MID") = sMID            '卡号
      CB("ID") = nSiteID          '消费记录号
      CB("Remain") = SumMoney     '结余
      If intDirect = 1 Then
         '充值
          CB("GetAmo") = curMoney
        Else
         '消费
          CB("Amo") = curMoney
      End If
      CB("Remark") = sMemo
      CB.Update
      CB.Close
      
   Exit Sub
AddERR:
   MsgBox "添加客户卡对帐单错误:" & Err.Description, vbCritical
   
End Sub

'退卡,返还卡内金额
Public Function BackCard(DBTmp As Connection, curMoney As Currency, sMID As String) As Boolean

  On Error GoTo AddERR
 'dbTmp 数据库,Curmoney为金额,sMID为会员ID
  Dim CB As Recordset
  Set CB = CreateObject("ADODB.Recordset")
      CB.Open "Select * from tbdMemberDetail", DBTmp, adOpenStatic, adLockOptimistic, adCmdText
      CB.AddNew
      CB("Date") = Date
      CB("lHour") = Hour(Time)
      CB("lMinute") = Minute(Time)
      CB("Oper") = UserText
      CB("MID") = sMID            '卡号
      CB("ID") = 0          '消费记录号
      CB("Remain") = 0      '结余
      CB("Amo") = curMoney
      CB("Remark") = "退卡：返还卡内剩余金额。"
      CB.Update
      CB.Close
      
     sArrearagePaymethod = ""
   
  '显示付款方式
   frmShowPayMethod.Show 1
   If sArrearagePaymethod = "" Then
      MsgBox "付款方式为空，不能保存？  ", vbExclamation
      BackCard = False
      Exit Function
   End If
      
  '支出现金帐单
   InserToCash DBTmp, 0, "客户〖" & sMID & "〗退卡,返还金额【" & curMoney & "元】", curMoney, Date, sArrearagePaymethod
  '修改今日与总金额
   InserTodayCash DBTmp, sArrearagePaymethod, -curMoney, Date
   
  '修改卡中金额
   Dim sTmpSQL As String
       sTmpSQL = "Update tbdMember Set Consume=0 Where ID='" & sMID & "'"
       DBTmp.Execute sTmpSQL
       
   BackCard = True
   
   Exit Function
AddERR:
   MsgBox "返还卡内剩作金额错误:" & Err.Description, vbCritical
   BackCard = False
   
End Function

'给出某某会员的最后余额
Public Function GetCount(DBTmp As Connection, stmpID As String) As Currency

  On Error GoTo AddERR
  Dim CB As Recordset
  Set CB = CreateObject("ADODB.Recordset")
      CB.Open "Select * from tbdMember Where ID='" & stmpID & "'", DBTmp, adOpenStatic, adLockOptimistic, adCmdText
      If CB.EOF And CB.BOF Then
         '没有记录时
          GetCount = 0
         Else
          GetCount = CB("Consume")
      End If
      CB.Close
      
   Exit Function
AddERR:
   MsgBox "给出会员余额错误:" & Err.Description, vbCritical
   
End Function

Public Sub InserToArrearage(DBTmp As Connection, nID As Long, sMID As String, sMName As String, curMoney As Currency, bDate As Date)

  On Error GoTo AddERR
 'dbTmp 数据库,intDirect为支出与收入,sMemo摘要,curMoney金额,bDate日期
  Dim CB As Recordset
  Set CB = CreateObject("ADODB.Recordset")
      CB.Open "tbdArrearage", DBTmp, adOpenStatic, adLockOptimistic, adCmdTable
      CB.AddNew
      CB("SheelID") = nID             '消费单号
      CB("MID") = sMID                '客户编号
      CB("MName") = sMName            '挂帐的经办人
      CB("MDate") = bDate
      CB("MOperator") = UserText
      CB("MAmount") = curMoney
      CB("MHour") = Hour(Time)
      CB("MMinute") = Minute(Time)
      CB.Update
      CB.Close
      
   Exit Sub
AddERR:
   MsgBox "添加挂帐错误:" & Err.Description, vbCritical
   
End Sub

'自动升级
Public Sub DetectUpdate(tmpID As String, upDB As Connection)
 
   On Error GoTo updateERR
   
  '检查ID,升级是否为最高级别
   Dim upRS As Recordset
   Dim sTMp As String
   
   Set upRS = CreateObject("ADODB.Recordset")
       upRS.ActiveConnection = upDB
       sTMp = "Select * from tbdMember Where ID='" & tmpID & "'"
       upRS.Open sTMp, , adOpenStatic, adLockOptimistic, adCmdText
      '没有找到该客户时，退出
       If upRS.EOF And upRS.BOF Then
          upRS.Close
          Set upRS = Nothing
          Exit Sub
       End If
        Dim intLevel As Integer
        Dim curDisks As Currency
        Dim curConsume As Currency
       '会员等级
        intLevel = upRS.Fields("DLevel")
       '挂帐金额
        curDisks = upRS.Fields("DArrearage")
       '消费累计
        curConsume = upRS.Fields("DConsum")
        
   '1/检测是否为最高会员，如果是不需进行升级
     If intLevel = 3 Then
        upRS.Close
        upDB.Close
        Set upRS = Nothing
        Set upDB = Nothing
        Exit Sub
     End If
   
   '2/给出上一级的标准
     Dim onRS As Recordset
     Set onRS = CreateObject("ADoDB.Recordset")
         onRS.ActiveConnection = upDB
         sTMp = "Select * from tbdLevel Where ID=" & intLevel + 1
         onRS.Open sTMp, , adOpenStatic, adLockReadOnly, adCmdText
         If onRS.EOF And onRS.BOF Then
            upRS.Close
            onRS.Close
            Set onRS = Nothing
            Set upRS = Nothing
            Exit Sub
         End If
   
   '3/给出标准
     sTMp = "Select * from tbdLevel Where DCashUp>" & curConsume & " And DCashDown<=" & curConsume
     onRS.Open sTMp, , adOpenStatic, adLockReadOnly, adCmdText
     If onRS.EOF And onRS.BOF Then
        upRS.Close
        onRS.Close
        Set onRS = Nothing
        Set upRS = Nothing
        Exit Sub
     End If
     onLevel = onRS.Fields("ID")
        
    Dim Allowupdate As Boolean    '是否可以升级
    
   '较对是否合适
    Allowupdate = (onLevel > intLevel)
    
    Dim sLevel As String
        Select Case onLevel
               Case 0
                 sLevel = "普通会员"
               Case 1
                 sLevel = "初级会员"
               Case 2
                 sLevel = "中级会员"
               Case 3
                 sLevel = "高级会员"
        End Select
        
   '提示是否升级
    If Allowupdate = True Then
       If MsgBox("会员【" & upRS("Name") & "】已经具有〖" & sLevel & "〗资格,是否立即自动升级？", vbInformation + vbYesNo) = vbNo Then
            upRS.Close
            onRS.Close
            Set onRS = Nothing
            Set upRS = Nothing
            Exit Sub
        Else
       '升级该会员
        upRS.Fields("DLevel") = onLevel
        upRS.Update
        MsgBox "会员自动升级完毕！   ", vbInformation
       End If
    End If
    upRS.Close
    onRS.Close
    Set onRS = Nothing
    Set upRS = Nothing
    Exit Sub
         
updateERR:
    MsgBox "自动升级错误:" & Err.Description, vbCritical
    Exit Sub
         
End Sub

'更新卡内金额
Public Sub UpdateRemain(DBTmp As Connection, smyID As String, curConsume As Currency)
 
  On Error GoTo ModifyERR
  
 '减少客户押金
  Dim sgTmp As String
      sgTmp = "Update tbdMember Set Consume=" & curConsume & " Where ID='" & smyID & "'"
      DBTmp.Execute sgTmp