modfocus.bas

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

Attribute VB_Name = "modFocus"
'******SQL服务器变量
  Public IsSqlDat As Boolean         '是否为SQL
  Public SQLServer As String
  Public SQLUser As String
  Public SQLPWD As String
  
'********************************窗体变量**********************
  Public SitesFocus As Boolean       '位置
  Public NewBookFocus As Boolean     '预订
  Public BrowserBookFocus As Boolean '查询
  Public MemberFocus As Boolean      '会员管理
  Public BaseFocus As Boolean        '基本配置
  Public IntegrationFocus As Boolean '酒席配置
  Public SystemConfigFile As String  '配置文件路径
  Public MenuFocus As Boolean        '菜单管理
  Public CustFocus As Boolean        '上台
  Public OtherFocus As Boolean       '其它配置时
  Public TodayCashFocus As Boolean   '今日消费
  Public ArrearageFocus As Boolean    '挂帐管理
  Public WasteBookFocus As Boolean    '流水帐
  Public HZSiteFocus As Boolean       '按座位汇总
  Public HZNameFocus As Boolean       '按名称汇总
  Public EmployFocus As Boolean       '员工管理
  Public OperatorFocus As Boolean     '操作员管理
  Public IsShare As Boolean           '是否为共享版
  
'************************************           ****************
  Public XLeft As Long                 '打印左边距
  Public XTop As Long                  '打印右边距
  Public xSmallLeft As Long            'POS打印左与顶
  Public xSmallTop As Long
  Public sCompanyTel As String         '公司电话
  Public sCompanyAdd As String         '公司地址
  Public nPrintLine As Integer         '打印的行数
  
'************************************           ****************
  Public AccessFile As String          '数据库变量
  Public Constr As String              '连接字符串
  Public sFindString As String         '共公搜索串
  Public sGuestID As String            '公共会员ID
  Public sGuestName As String          '公共会员名称
  Public cGuestRemain As Currency      '公共会员金额
  Public sGuestTel As String           '公共会员联系电话
  Public MakeFind As Boolean           '是否查询
  
'*********************************** 菜单变量 *****************
  Public sPubSite As String          '共享餐位
  Public sMenuName As String         '菜单名称
  Public sMenuID   As String         '菜单编号
  Public sPubType As String          '共享的菜单类型
  Public cRate As Currency           '会员打折率
  Public sInfoSite As String         '座位编号
  Public IsAutorun As Integer         '自动运行
  Public sInfo As String              '显示消息
  Public IsChangeIT  As Boolean       '已经改变时
  Public strSearch As String
  Public Logined As Boolean           '是否登录成功
  Public StrPathId As String
  Public StrProId As String
  Public strType As String
  Public strRecName As String
  Public strValue As String
  Public AllowDZ As Boolean            '允许打折
  Public DeletePre As Boolean          '删除预订内容，在落单后
  Public sTmpWaiter As String          '服务员全局变量
  
 '挂帐结帐时的付款方法
  Public sArrearagePaymethod As String
  Public sContact As String              '联系人
  Public sWeb As String                  '网址
  
 '时间段变量---------------------------------------------------
  Public Lunch1 As Integer               '中午
  Public Lunch2 As Integer               '中午
  Public Supper1 As Integer               '中午
  Public Supper2 As Integer               '中午
  Public Night1 As Integer               '中午
  Public NIght2 As Integer               '中午
  
 '自动删除过期预订内容=========================================CheckRun函数使用
  Public AtCheckRun As Boolean           '正在进行Check
  Public curDatePart As Integer          '已经检查的时间段
  
'给出数据库路径
Public Sub GetAccessFile(sAF As String)

   On Error GoTo GetERR
      
      Dim sFTmp As String
          sFTmp = App.Path
       If Right(sFTmp, 1) <> "\" Then
          sFTmp = sFTmp & "\"
       End If
       
  '首次运行没有指定时,给出缺省路径
   If Trim(sAF) = "" Then
      AccessFile = sFTmp & "systemdata.mdb"
      Exit Sub
   End If
   
  '给出缺省路径
   If Dir(sAF, vbArchive) = "" Then
      AccessFile = sFTmp & "systemdata.mdb"
      MsgBox "系统的Systemdata.mdb数据库配置不正确,请在基本配置中修改。 " _
         & vbCrLf & "然后重新启动餐饮收银管理系统。   " _
         & vbCrLf & "系统目前使用本地安装缺省数据库。    ", vbExclamation
   End If
   
   Exit Sub
GetERR:
   MsgBox "对不起,不能给出Systemdata.mdb数据库文件。    " _
    & vbCrLf & "重新启动餐饮收银管理系统。   ", vbCritical
   
End Sub

'设置记帐状态
 Public Function SetCashOut(stmpSite As String, iStatus As Integer) As Boolean
   
   On Error GoTo SetErr
   
   Dim sDB As Connection
   Dim sTMp As String
   Set sDB = CreateObject("ADODB.Connection")
       sDB.Open Constr
       sTMp = "Update SiteType Set SiteStatus=" & iStatus & " Where Class='" & stmpSite & "'"
       sDB.Execute sTMp
       sDB.Close
       Set sDB = Nothing
       SetCashOut = True
   
   Exit Function
SetErr:
   MsgBox "不能设置当前座位状态为 3 :" & Err.Description, vbInformation
   SetCashOut = False
   
 End Function

'更新单据号码
Public Function UpdateNo(sType As String)

  On Error GoTo UpdateNOErr
  Dim DBF As Connection
  Dim EFF As Recordset
    
  Set DBF = CreateObject("ADODB.Connection")
      DBF.Open Constr
  Set EFF = CreateObject("ADODB.Recordset")
      If IsSqlDat = True Then
         EFF.Open "Select * from tbdSheel Where SheelDate='" & Date & "' and SheelType='" & sType & "'", DBF, adOpenStatic, adLockOptimistic, adCmdText
      Else
         EFF.Open "Select * from tbdSheel Where SheelDate=#" & Date & "# and SheelType='" & sType & "'", DBF, adOpenStatic, adLockOptimistic, adCmdText
      End If
  If Not (EFF.EOF And EFF.BOF) Then
     EFF.Fields("SheelNO") = EFF.Fields("SheelNO") + 1
     EFF.Update
    Else
     EFF.AddNew
     EFF.Fields("SheelDate") = Date
     EFF.Fields("SheelType") = sType
     EFF.Fields("SheelNO") = 1
     EFF.Update
  End If
  EFF.Close
  Set EFF = Nothing
  DBF.Close
  Set DBF = Nothing
  
  Exit Function
UpdateNOErr:
  MsgBox " 更新单号错误：" & Err.Description, vbCritical
  Exit Function
    
End Function

'给出目前单号
Public Function GetNo(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='" & Date & "' and SheelType='" & sType & "'", DFF, adOpenStatic, adLockReadOnly, adCmdText
      Else
         EFF.Open "Select * from tbdSheel Where SheelDate=#" & Date & "# and SheelType='" & sType & "'", DFF, adOpenStatic, adLockReadOnly, adCmdText
      End If
      
  If Not (EFF.EOF And EFF.BOF) Then
     nNO = EFF.Fields("SheelNO") + 1
    Else
     nNO = 1
  End If
      EFF.Close
  Set EFF = Nothing
      DFF.Close
  Set DFF = Nothing
  
  'Year,Month,Date
  sYear = Year(Date)
  sMonth = Month(Date)
  sDate = Day(Date)
 '一位的月份时
  If Len(sMonth) = 1 Then
     sMonth = "0" & sMonth
  End If
 '一位、二位、三位的日时
  If Len(sDate) = 1 Then
     sDate = "0" & sDate
  End If
  
  sNO = Trim(CStr(nNO))
      
  GetNo = sYear + sMonth + sDate + sNO
  
  Exit Function
UpdateNOErr:
  MsgBox "给出单号错误：" & Err.Description, vbCritical
  GetNo = str(Date)
  
End Function

'给出预订ID
Public Function GetBookID(sBookString As String)
  
  GetBookID = Mid(sBookString, 2, Len(sBookString) - 1)
    
End Function

Public Sub ViewBook(sBookID As String)

  If sBookID = "" Then
     MsgBox "预订单号为空，不能查看单据。  ", vbInformation
     Exit Sub
  End If
  
  frmviewBook.tmpID = sBookID
  frmviewBook.Show 1
  
End Sub

'取消预订
Public Function CancelBook(sBookID As String) As Boolean
 
 On Error GoTo CancelERR
  
 If MsgBox("真的取消该预订内容吗？ " & vbCrLf _
      & "取消后将不能恢复，是否同意。   ", vbInformation + vbYesNo) = vbNo Then
    CancelBook = False
    Exit Function
 End If
 
 Dim CDB As Connection
 Dim sDel As String
 Set CDB = CreateObject("ADODB.Connection")
     CDB.Open Constr
     CDB.BeginTrans
     sDel = "Delete from tbdBook Where ID='" & sBookID & "'"
     CDB.Execute sDel
     Dim tmplHour, tmpDatePart As Integer
         tmplHour = Hour(Time)
      If tmplHour >= Lunch1 And tmplHour < Lunch2 Then   '中午
         tmpDatePart = 1
       ElseIf tmplHour >= Supper1 And tmplHour < Supper2 Then   '下午
         tmpDatePart = 2
       ElseIf tmplHour >= Night1 And tmplHour < NIght2 Then     '晚上
         tmpDatePart = 3
       Else
         tmpDatePart = 1
      End If
    '1、清除所有预订台状态
     sDel = "Update SiteType Set SiteStatus=0 Where SiteStatus=1"
     CDB.Execute sDel
     If IsSqlDat = True Then
        sDel = "Update SiteType Set SiteStatus=1 Where Class In (Select Class From tbdBook Where ExpireDate='" & Date & "' And DatePart=" & tmpDatePart & ") And SiteStatus<2"
        Else
        sDel = "Update SiteType Set SiteStatus=1 Where Class In (Select Class From tbdBook Where ExpireDate=#" & Date & "# And DatePart=" & tmpDatePart & ") And SiteStatus<2"
     End If
    '2、设置当前时间段的预订
     CDB.Execute sDel
     
     CDB.CommitTrans
     CDB.Close
     Set CDB = Nothing
     CancelBook = True
     
  Exit Function
CancelERR:
  CancelBook = False
  MsgBox "对不起,取消预订错误？  ", vbCritical
  
End Function

'通过座位给出预订的编号
Public Function GetID(tmpS As String) As String
 
 On Error GoTo CancelERR
 
 Dim CDB As Connection
 Dim CRs As Recordset
 Dim sDel As String
 Set CDB = CreateObject("ADODB.Connection")
 Set CRs = CreateObject("ADODB.Recordset")
     CDB.Open Constr
     
     Dim tmplHour, tmpDatePart As Integer
         tmplHour = Hour(Time)
      If tmplHour >= Lunch1 And tmplHour < Lunch2 Then   '中午
         tmpDatePart = 1
       ElseIf tmplHour >= Supper1 And tmplHour < Supper2 Then   '下午
         tmpDatePart = 2
       ElseIf tmplHour >= Night1 And tmplHour < NIght2 Then     '晚上
         tmpDatePart = 3
       Else
         tmpDatePart = 1
      End If
      If IsSqlDat = True Then
         sDel = "Select * from tbdBook Where Class='" & tmpS & "' And ExpireDate='" & Date & "' And DatePart=" & tmpDatePart
        Else
         sDel = "Select * from tbdBook Where Class='" & tmpS & "' And ExpireDate=#" & Date & "# And DatePart=" & tmpDatePart
      End If
      CRs.Open sDel, CDB, adOpenStatic, adLockReadOnly, adCmdText
      If Not (CRs.EOF And CRs.BOF) Then
         GetID = CRs("ID")
        Else
         GetID = ""
      End If
      CDB.Close
      Set CDB = Nothing
           
  Exit Function
CancelERR:
  GetID = ""
  MsgBox "对不起,给出预订ID错误？  " & Err.Description, vbCritical
  
End Function

'设置餐桌为维护状态
Public Function Maintenans(stmpSiteID As String) As Boolean
 
 On Error GoTo CancelERR
  
 If MsgBox("真的设置该座位为维修状态吗？ " & vbCrLf _
      & "维修状态时不能预订，也不能上台。", vbInformation + vbYesNo) = vbNo Then
    Maintenans = False
    Exit Function
 End If
 
 Dim CDB As Connection
 Dim sDel As String
 Set CDB = CreateObject("ADODB.Connection")
     CDB.Open Constr
     CDB.BeginTrans
     sDel = "Update SiteType Set SiteStatus=4 Where Class='" & stmpSiteID & "'"
     CDB.Execute sDel
     CDB.CommitTrans
     CDB.Close
     Set CDB = Nothing
     Maintenans = True
     
  Exit Function
CancelERR:
  Maintenans = False
  MsgBox "设置为维修状态错误？" & Err.Description, vbCritical
  
End Function

'恢复餐桌状态
Public Function CancelMaintenans(stmpSiteID As String) As Boolean
 
 On Error GoTo CancelERR
  
 If MsgBox("真的恢复该座位为正常状态吗？ " & vbCrLf _
      & "恢复后，该台可以预订、上台。", vbInformation + vbYesNo) = vbNo Then
    CancelMaintenans = False
    Exit Function
 End If
 
 Dim CDB As Connection
 Dim sDel As String
 Set CDB = CreateObject("ADODB.Connection")
     CDB.Open Constr
     CDB.BeginTrans
     sDel = "Update SiteType Set SiteStatus=0 Where Class='" & stmpSiteID & "'"
     CDB.Execute sDel
    '检索是否有预订
     Dim tmplHour, tmpDatePart As Integer
         tmplHour = Hour(Time)
      If tmplHour >= Lunch1 And tmplHour < Lunch2 Then   '中午
         tmpDatePart = 1
       ElseIf tmplHour >= Supper1 And tmplHour < Supper2 Then   '下午
         tmpDatePart = 2
       ElseIf tmplHour >= Night1 And tmplHour < NIght2 Then     '晚上
         tmpDatePart = 3
       Else
         tmpDatePart = 1
      End If
     If IsSqlDat = True Then