modfocus.bas

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

  Exit Sub
ModifyERR:
  MsgBox "更新客户卡内金额错误:" & Err.Description, vbCritical
  Exit Sub
   
End Sub

'更新客户累计
Public Sub UpdateGuestLJ(DBTmp As Connection, smyID As String, curConsume As Currency, curArrearage As Currency)
 
  On Error GoTo ModifyERR
 
 '减少客户押金
  Dim sgTmp As String
      sgTmp = "Update tbdMember Set DConsum=DConsum+" & curConsume & ",DArrearage=Darrearage+" & curArrearage & " Where ID='" & smyID & "'"
      DBTmp.Execute sgTmp
         
  Exit Sub
ModifyERR:
  MsgBox "更新客户累计消费错误:" & Err.Description, vbCritical
  Exit Sub
  
End Sub

'插入到当日现金表中
Public Sub InserTodayCash(DBTmp As Connection, sTmpType As String, curMoney As Currency, bDate As Date)

 '没有分类时不添加
  If sTmpType = "" Then Exit Sub
  
  On Error GoTo AddERR
  Dim CBRs As Recordset
  Set CBRs = CreateObject("ADODB.Recordset")
      If IsSqlDat = True Then
         CBRs.Open "Select * from tbdCash Where DType='" & sTmpType & "' And DDate='" & bDate & "'", DBTmp, adOpenStatic, adLockOptimistic, adCmdText
       Else
         CBRs.Open "Select * from tbdCash Where DType='" & sTmpType & "' And DDate=#" & bDate & "#", DBTmp, adOpenStatic, adLockOptimistic, adCmdText
      End If
      If CBRs.EOF And CBRs.BOF Then
        '每天第一张单据时
         CBRs.AddNew
         CBRs("DDate") = bDate
         CBRs("DType") = sTmpType
         CBRs("DNumber") = 1
         CBRs("DCash") = curMoney
        Else
        '数量添加，金额添加
         If curMoney < 0 Then
           '为负数量，表示还原或删除时
            CBRs("DNumber") = CBRs("DNumber") - 1
          Else
            CBRs("DNumber") = CBRs("DNumber") + 1
         End If
         CBRs("DCash") = CBRs("DCash") + curMoney
       End If
       CBRs.Update
       CBRs.Close
       
  '同时一起更新现金总表中内容
       
   Exit Sub
AddERR:
   MsgBox "更新现金库错误:" & Err.Description, vbCritical
   
End Sub

Public Sub ChangeIt(sFirstSite As String)

    On Error GoTo ERR_HZ
    Dim DB As Connection
    Dim EF As Recordset
    Dim lSheelID As Long
    Set DB = CreateObject("ADODB.Connection")
    Set EF = CreateObject("ADODB.Recordset")
    Dim sTMp As String
        DB.Open Constr
        EF.Open "Select * From tmpSite Where Site='" & sFirstSite & "'", DB, adOpenStatic, adLockReadOnly, adCmdText
       '首先检测该座位有没有上台，如果没有上台将不能调换
        If EF.BOF And EF.EOF Then  '没有记录时为0
           EF.Close
           Set EF = Nothing
           DB.Close
           Set DB = Nothing
           MsgBox "对不起，【餐桌" & sFirstSite & "】没有消费记录！   " & vbCrLf & vbCrLf & "不能进行〖换桌〗请求！  ", vbInformation
           Exit Sub
        End If
           EF.Close
           Dim sNewSite As String
               sNewSite = Trim(InputBox("请输入要换的桌号或座位号！   "))
           If sNewSite = "" Then
               DB.Close
               Set DB = Nothing
               'MsgBox "调换的桌号为空不能换桌！   ", vbInformation
               Exit Sub
           End If
          '如果一样时
           If UCase(sNewSite) = UCase(sFirstSite) Then
               DB.Close
               Set DB = Nothing
               MsgBox "两桌号一样不能换桌,如何使得？   ", vbInformation
               Exit Sub
           End If
          '检测该座位是否在使用
               EF.Open "Select * From SiteType Where Class='" & sNewSite & "'", DB, adOpenStatic, adLockReadOnly
               '检测该座位是否有效
               If EF.BOF And EF.EOF Then '不存在时
                  EF.Close
                  Set EF = Nothing
                  DB.Close
                  Set DB = Nothing
                  MsgBox "该桌号没有定义，不能换桌！   " & vbCrLf & vbCrLf & "请首先在【基本配置】中〖座位分类〗中添加桌号？   ", vbInformation
                  Exit Sub
                 Else
                   If EF("SiteStatus") = 2 Then
                     '上台时，正在用餐
                      EF.Close
                      Set EF = Nothing
                      DB.Close
                      Set DB = Nothing
                      MsgBox "该桌正在用餐，不能换桌！   " & vbCrLf & vbCrLf & "调换必须为空闲座位（餐桌）？   ", vbInformation
                      Exit Sub
                   Else
                      EF.Close
                      Set EF = Nothing
                     '换桌动作
                      DB.BeginTrans
                     '更新
                      sTMp = "Update tmpSite Set Site='" & sNewSite & "' Where Site='" & sFirstSite & "'"
                      DB.Execute sTMp
                      sTMp = "Update tmpCust Set Site='" & sNewSite & "' Where Site='" & sFirstSite & "'"
                      DB.Execute sTMp
                     '恢复该座号的状态
                      sTMp = "Update SiteType Set SiteStatus=0 Where Class='" & sFirstSite & "'"
                      DB.Execute sTMp
                     '修改调换后的状态
                      sTMp = "Update SiteType Set SiteStatus=2 Where Class='" & sNewSite & "'"
                      DB.Execute sTMp
                      DB.CommitTrans
                      DB.Close
                      Set DB = Nothing
                      MsgBox "桌号已经更换，请到【客人上台】区管理。    ", vbInformation
                   End If
               End If
           
        
               Exit Sub
ERR_HZ:
        MsgBox "对不起，换桌错误：   " & vbCrLf & vbCrLf & Err.Description, vbInformation
        Exit Sub
        
End Sub

Public Sub CopyIt(sFirstSite As String)

 On Error GoTo ERR_HZ
    Dim DB As Connection
    Dim EF As Recordset
    Dim lSheelID As Long
    Set DB = CreateObject("ADODB.Connection")
    Set EF = CreateObject("ADODB.Recordset")
        DB.Open Constr
        EF.Open "Select * From tmpSite Where Site='" & sFirstSite & "'", DB, adOpenStatic, adLockReadOnly, adCmdText
       '首先检测该座位有没有上台，退出
        If EF.BOF And EF.EOF Then  '没有记录时为0
           EF.Close
           Set EF = Nothing
           DB.Close
           Set DB = Nothing
           MsgBox "对不起，没有找到[" & sFirstSite & "]消费记录单！   " & vbCrLf & vbCrLf & "不能进行【同桌】请求！  ", vbInformation
           Exit Sub
        End If
        EF.Close
        Set EF = Nothing
        DB.Close
        Set DB = Nothing
            sPubSite = sFirstSite  '桌号保存
           '显示未消费的桌
            frmCopysite.Show 1
        Exit Sub
        
ERR_HZ:
        MsgBox "对不起，同桌复制错误：   " & vbCrLf & vbCrLf & Err.Description, vbInformation
        Exit Sub
End Sub

Public Function DeleteGoto(nID As Long) As Boolean

  On Error GoTo DelErr
  
  Dim bDB As Connection
  Dim sTMp As String
     
  If nID = 0 Then Exit Function
  
  If MsgBox("真要删除[" & nID & "]号消费单吗？（Y/N）  ", vbInformation + vbYesNo) = vbNo Then
     DeleteGoto = False
     Exit Function
  End If
 
       Set bDB = CreateObject("ADODB.Connection")
           bDB.Open Constr
           
           Dim FG As Recordset
           Dim lID As Long
           Dim IsGZ As Integer
           Dim curMoney As Currency           '金额
           Dim sMemberID As String            '如果为会员时,必须修改该会员的累计
           Dim sPaymethod As String
           Dim tmpCur As Currency

               curMoney = 0: sMemberID = "": IsGZ = 0
           
           Set FG = CreateObject("ADODB.Recordset")
             '打开该坐位的所有记录
              FG.Open "Select * From Site Where ID=" & nID, bDB, adOpenStatic, adLockReadOnly, adCmdText
            '2没有找到该座位的消费记录
             If FG.EOF And FG.BOF Then '没有记录时
                FG.Close
                bDB.Close
                Set FG = Nothing
                Set bDB = Nothing
                MsgBox "对不起，没有找到编号为【" & nID & "】消费单！  " & vbCrLf _
                   & "请确认是不是其他用户已经删除该单,请刷新再试试？   ", vbInformation
                Exit Function
               Else
                lID = FG.Fields("ID")            '给出该座位的最后一次消费的单号
                curMoney = FG("SFAmo")
                sMemberID = NullValue(FG("MID"))
                IsGZ = FG("IsArrearage")        '挂帐
                sPaymethod = NullValue(FG("tmpStr"))
                tmpCur = FG("tmpCur")
                FG.Close
              End If
              Set FG = Nothing
              
               bDB.BeginTrans
               
              '删除单据明细与座位信息
               sTMp = "Delete From Site Where ID=" & lID
               bDB.Execute sTMp
               sTMp = "Delete From Cust Where SheelID=" & lID
               bDB.Execute sTMp
               
              '如果非挂帐时
               If IsGZ = 0 Then
                 '还原流水帐
                  If tmpCur = curMoney Then        '所有都以卡付时
                    If tmpCur > 0 Then
                       Dim tmpRemain As Currency
                           tmpRemain = GetCount(bDB, sMemberID) + tmpCur
                          '补充卡值
                           InserToCard bDB, 1, "『" & lID & "』号消费单还原" & Time, tmpCur, sMemberID, lID, tmpRemain
                           InserToCash bDB, 0, "消费单还原", tmpCur, Date, sPaymethod
                          '修改今日与总金额
                           InserTodayCash bDB, "会员卡付", -tmpCur, Date
                          '更新最后余额
                           UpdateRemain bDB, sMemberID, tmpRemain
                    End If
                   Else                           '卡与其它合用时
                    If tmpCur > 0 Then
                        InserToCash bDB, 0, "消费单还原", curMoney - tmpCur, Date, sPaymethod
                        InserTodayCash bDB, sPaymethod, -(curMoney - tmpCur), Date
                        InserToCard bDB, 1, "『" & lID & "』号消费单还原" & Time, tmpCur, sMemberID, lID, tmpRemain
                        InserTodayCash bDB, "会员卡付", -tmpCur, Date
                        InserToCash bDB, 0, "消费单还原", tmpCur, Date, "会员卡付"
                      Else
                      '不使用卡时
                        InserToCash bDB, 0, "消费单还原", curMoney, Date, sPaymethod
                        InserTodayCash bDB, sPaymethod, -curMoney, Date
                     End If
                  End If
                 '如果客户不为空时
                  If sMemberID <> "" Then
                     UpdateGuestLJ bDB, sMemberID, -curMoney, 0
                  End If
                Else
                '挂帐时
                 If sMemberID <> "" Then
                    UpdateGuestLJ bDB, sMemberID, 0, -curMoney
                 End If
               '修改挂帐中金额及付款日期
                'sTmp = "Update tbdArrearage Set MSFAmount=" & curMoney & ",MReturn=1,MRDate=#" & Date & "# Where SheelID=" & lID
                '直接删除消费单
                 sTMp = "Delete tbdArrearage Where SheelID=" & lID
                 bDB.Execute sTMp
               End If
               
              bDB.CommitTrans
              bDB.Close
          Set bDB = Nothing
          DeleteGoto = True
          
          Exit Function
DelErr:
          MsgBox "删除消费单错误:" & Err.Description, vbCritical
          DeleteGoto = False
          
End Function

'给出产品编号，不重复
Public Function GetNewNo(sType As String) As String
  
  On Error GoTo GetnoERR
  
  Dim noDB As Connection
  Dim noRS As Recordset
  Dim tmpString As String
   
  Set noDB = CreateObject("ADODB.Connection")
  Set noRS = CreateObject("ADODB.Recordset")
      noDB.Open Constr
      tmpString = "Select * from tbdFileSheel Where Sheeltype='" & sType & "'"
      noRS.Open tmpString, noDB, adOpenStatic, adLockReadOnly, adCmdText
      If Not (noRS.EOF And noRS.BOF) Then
         GetNewNo = noRS("SheelID") + 1
         Select Case Len(GetNewNo)
          Case 1
            GetNewNo = "0000" & GetNewNo
          Case 2
            GetNewNo = "000" & GetNewNo
          Case 3
            GetNewNo = "00" & GetNewNo
          Case 4
            GetNewNo = "0" & GetNewNo
          Case Else
          End Select
        Else
         GetNewNo = ""
      End If
  
  noRS.Close
  noDB.Close
  Set noRS = Nothing
  Set noDB = Nothing
  
  Exit Function
GetnoERR:
  GetNewNo = ""
  
End Function

'更新会员或产品总数
Public Sub SaveNewNo(sType As String, TmpDB As Connection)

  On Error GoTo GetnoERR
  
  Dim tmpString As String
      tmpString = "Update tbdFileSheel Set SheelID=SheelID+1 Where Sheeltype='" & sType & "'"
      TmpDB.Execute tmpString
  
  Exit Sub
GetnoERR:
  MsgBox "更新单号错误:" & Err.Description, vbCritical
  
End Sub

'通过类型，给出固定的ID号
Public Function GetFixNo(sType As String)

  On Error GoTo UpdateNOErr:
  
  Dim DFF As Connection
  Dim EFF As Recordset
  Dim nNO As Long
  Dim sYear As String, sMonth As String, sDate As String, sNO As String
  
  Set DFF = CreateObject("ADODB.Connection")
      DFF.Open Constr
  Set EFF = CreateObject("ADODB.Recordset")
       
      If IsSqlDat = True Then
         EFF.Open "Select * from tbdSheel Where SheelDate='2002-07-19' and SheelType='" & sType & "'", DFF, adOpenStatic, adLockOptimistic, adCmdText
      Else
         EFF.Open "Select * from tbdSheel Where SheelDate=#2002-07-19# and SheelType='" & sType & "'", DFF, adOpenStatic, adLockOptimistic, adCmdText
      End If
      
  If EFF.EOF And EFF.BOF Then
     EFF.AddNew
     EFF("SheelDate") = "2002-07-19"
     EFF("sheelType") = sType
     EFF("SheelNO") = 1
     EFF.Update
     nNO = 1
    Else
     nNO = EFF.Fields("SheelNO") + 1
     EFF("SheelNO") = nNO
     EFF.Update
  End If
      EFF.Close
  Set EFF = Nothing
      DFF.Close
  Set DFF = Nothing
     
 '给出数字
  GetFixNo = Trim(str(nNO))
  
  Exit Function
UpdateNOErr:
  MsgBox "给出FIX单号错误：" & Err.Description, vbCritical
  GetFixNo = 1
  
End Function