frmmainmain.frm

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

     frmNewBook.SetFocus
     frmNewBook.ftClass = sPubSite
  End If
   
End Sub

Private Sub mnuOther_Click()

  If mnuOther.Enabled = False Then
     MsgBox "很抱歉，禁止访问！  ", vbInformation
     Exit Sub
  End If
  If OtherFocus = True Then
     frmOther.SetFocus
    Else
     frmOther.Show
  End If
   
End Sub

Private Sub mnuPrint_Click()

  '显示打印飞单程序
   frmPrint.Show 1
   
End Sub

Private Sub mnuProccess_Click()
 
   If mnuProccess.Enabled = False Then
     MsgBox "很抱歉，禁止访问！  ", vbInformation
     Exit Sub
  End If
   If OperatorFocus = True Then
     frmOperator.SetFocus
    Else
     frmOperator.Show
   End If

End Sub

Private Sub mnuQueryCustomer_Click()

    'frmQuerySell.Show
  
End Sub

Private Sub mnuQueryEnter_Click()

   'frmQueryEnter.Show

End Sub

Private Sub mnuQuerySystem_Click()
  
   'frmCustomerOrder.Show
 
End Sub



Private Sub mnuSiteCount_Click()

  If mnuSiteCount.Enabled = False Then
     MsgBox "很抱歉，禁止访问！  ", vbInformation
     Exit Sub
  End If
  If HZSiteFocus = True Then
     frmHZSite.SetFocus
    Else
     frmHZSite.Show
  End If
 
End Sub

Private Sub mnuSites_Click()

  If mnuSites.Enabled = False Then
     MsgBox "很抱歉，禁止访问！  ", vbInformation
     Exit Sub
  End If
  
  If SitesFocus = False Then
     frmSites.Show
    Else
     frmSites.SetFocus
  End If
              
End Sub

Private Sub mnuSort_Click()

  'frmSellList.Show
  
End Sub

Private Sub mnuStart_Click()

  If mnuStart.Enabled = False Then
     MsgBox "很抱歉，禁止访问！  ", vbInformation
     Exit Sub
  End If
  If CustFocus = True Then
     frmCustomerForm.SetFocus
    Else
     frmCustomerForm.Show
  End If
  
End Sub

Private Sub mnuSystemClear_Click()

  If mnuSystemClear.Enabled = False Then
     MsgBox "很抱歉，禁止访问！  ", vbInformation
     Exit Sub
  End If
  frmClean.Show 1

End Sub

Private Sub mnuTime_Click()

  frmTime.Show 1
  
End Sub

Private Sub mnuTongJi_Click()

  If mnuTongJi.Enabled = False Then
     MsgBox "很抱歉，禁止访问！  ", vbInformation
     Exit Sub
  End If
  If TodayCashFocus = True Then
     frmTodayConsume.SetFocus
    Else
     frmTodayConsume.Show
  End If
     
End Sub

Private Sub mnuWastebook_Click()
 
  If mnuWastebook.Enabled = False Then
     MsgBox "很抱歉，禁止访问！  ", vbInformation
     Exit Sub
  End If
  If WasteBookFocus = True Then
    frmWasteBook.SetFocus
   Else
    frmWasteBook.Show
  End If
   
End Sub

Private Sub picTool_Resize()

   On Error Resume Next
   
   If Me.WindowState = 1 Then Exit Sub
   
   VerticalMenu1.Width = picTool.ScaleWidth - 40
   VerticalMenu1.Height = picTool.ScaleHeight - 40

End Sub

Private Sub Timer1_Timer()
  
  lbInfo.Caption = sInfo
 '移动显示信息
  If lbInfo.Left < -lbInfo.Width Then
     lbInfo.Left = infoLeft
    Else
     lbInfo.Move lbInfo.Left - 10
  End If
  
End Sub

Private Sub Timer2_Timer()

  If AtCheckRun = True Then Exit Sub
  
 '删除过时的预订
  CheckRun
  
End Sub

Private Sub VerticalMenu1_MenuItemClick(MenuNumber As Long, MenuItem As Long)

   Select Case MenuNumber
     Case 1
       '预订功能
        Select Case MenuItem
          Case 1
            mnuSites_Click
          Case 2
            mnuNewBook_Click
          Case 3
            mnuFindBook_Click
        End Select
     Case 2
       Select Case MenuItem
         Case 1
          '客人上台
            mnuStart_Click
         Case 2
          '消费统计
            mnuTongJi_Click
         Case 3
          '挂帐管理
            mnuArrearage_Click
         Case 4
          '结帐后退单
           Call mnuCheckOut_Click
       End Select
     Case 3
       '会员管理
        Select Case MenuItem
          Case 1
            mnuMember_Click
          Case 2
            mnuLevel_Click
        End Select
     Case 4
       Select Case MenuItem
        Case 1
         '流水帐
          Call mnuWastebook_Click
        Case 2
         '按座位汇总
          Call mnuSiteCount_Click
        Case 3
         '按菜名汇总
          Call mnuName_Click
       End Select
        
     Case 5
        '基本配置
         Select Case MenuItem
           Case 1
             mnuBase_Click
           Case 2
             mnuIntegration_Click
           Case 3
             mnuMenuManager_Click
         End Select
     Case 6
        Select Case MenuItem
            Case 1                          '其它配置
                Call mnuOther_Click
            Case 2                          '员工
                Call mnuEmploy_Click
            Case 3                          '操作员
                Call mnuProccess_Click
            Case 4
                Call mnuBackup_Click        '备份
            Case 5
                Call mnuSystemClear_Click         '重建
        End Select
   End Select
  
End Sub

Public Sub CheckAuthor(IsTrue As Boolean)
 
   '权限检测
    mnuSites.Enabled = IsTrue
    mnuNewBook.Enabled = IsTrue
    mnuFindBook.Enabled = IsTrue
    mnuBase.Enabled = IsTrue
    mnuIntegration.Enabled = IsTrue
    mnuMenuManager.Enabled = IsTrue
    mnuLevel.Enabled = IsTrue
    mnuMember.Enabled = IsTrue
    'mnuOther.Enabled = IsTrue
    mnuEmploy.Enabled = IsTrue
    mnuProccess.Enabled = IsTrue
    mnuBackup.Enabled = IsTrue
    mnuSystemClear.Enabled = IsTrue
    mnuStart.Enabled = IsTrue
    mnuTongJi.Enabled = IsTrue
    mnuArrearage.Enabled = IsTrue
    mnuCheckOut.Enabled = IsTrue
    mnuWastebook.Enabled = IsTrue
    mnuSiteCount.Enabled = IsTrue
    mnuName.Enabled = IsTrue
    mnuTime.Enabled = IsTrue
    mnuPrint.Enabled = IsTrue
    mnuBox.Enabled = IsTrue
          
End Sub

Public Function CheckLogin(sID As String, sPWD As String) As Boolean
 
    On Error GoTo GetERR
    
    If sID = "" Then Exit Function
    
    Dim vDB As Connection
    Dim vRS As Recordset
    Set vDB = CreateObject("ADODB.Connection")
    Set vRS = CreateObject("ADODB.Recordset")
        vDB.Open Constr
        vRS.Open "Select * from Main Where 操作员='" & sID & "' And 口令='" & SecretPWD(sPWD) & "'", vDB, adOpenStatic, adLockReadOnly, adCmdText
                
       If vRS.EOF And vRS.BOF Then
          vRS.Close
          vDB.Close
          Set vRS = Nothing
          Set vDB = Nothing
          CheckLogin = False
          'MsgBox "用户名或口令不正确？  ", vbInformation
          Exit Function
       ElseIf sID = "超级用户" Then
          CheckAuthor True
       Else
        '权限检测
         mnuSites.Enabled = vRS("AUTHOR0")
         mnuNewBook.Enabled = vRS("AUTHOR1")
         mnuFindBook.Enabled = vRS("AUTHOR2")
         mnuBase.Enabled = vRS("AUTHOR3")
         mnuIntegration.Enabled = vRS("AUTHOR4")
         mnuMenuManager.Enabled = vRS("AUTHOR5")
         mnuLevel.Enabled = vRS("AUTHOR6")
         mnuMember.Enabled = vRS("AUTHOR7")
         mnuOther.Enabled = vRS("AUTHOR8")
         mnuEmploy.Enabled = vRS("AUTHOR9")
         mnuProccess.Enabled = vRS("AUTHOR10")
         mnuBackup.Enabled = vRS("AUTHOR11")
         mnuSystemClear.Enabled = vRS("AUTHOR12")
         mnuStart.Enabled = vRS("AUTHOR13")
         mnuTongJi.Enabled = vRS("AUTHOR14")
         mnuArrearage.Enabled = vRS("AUTHOR15")
         mnuCheckOut.Enabled = vRS("AUTHOR16")
         mnuWastebook.Enabled = vRS("AUTHOR17")
         mnuSiteCount.Enabled = vRS("AUTHOR18")
         mnuName.Enabled = vRS("AUTHOR19")
         mnuBox.Enabled = vRS("AUthor20")
         mnuPrint.Enabled = vRS("AUTHOR21")
         mnuTime.Enabled = vRS("AUTHOR22")
         
       End If
          vRS.Close
          vDB.Close
          Set vRS = Nothing
          Set vDB = Nothing
          CheckLogin = True
          
    Exit Function
GetERR:
    CheckLogin = False
    MsgBox "检测权限错误:" & Err.Description & vbCrLf _
      & "请检查数据库配置是否正确,否则通过其它配置来选择？  ", vbCritical
    
End Function

Private Function GetShare() As Boolean
 
' On Error GoTo REGERR
 
' Dim tmpPoint As Integer
' Dim vbReg As New VBChina
' Dim Novalid As Boolean
' Dim sID As String, sUser As String
'给出注册码
' Dim fIni As RegClass
' Set fIni = New RegClass
    'sUser = fIni.ReadINIString("System", "CompanyName", "", SystemConfigFile)
'    If sUser <> "" Then
 '      tmpPoint = InStr(1, sUser, Chr(0), vbTextCompare)
  '    If tmpPoint > 1 Then
   '      sUser = Left(sUser, tmpPoint - 1)
    '  End If
    'End If
    'sID = fIni.ReadINIString("System", "CompanyID", "", SystemConfigFile)
    'Set fIni = Nothing
 'If sUser = "" Or sID = "" Then
     'GetShare = True
     'Exit Function
  'Else
    '两者都不为空时
    ' vbReg.CompanyName = sUser
'     vbReg.CompanyID = sID
 '    If vbReg.Encrypt(sID, "E" & sUser & "C") = True Then
        GetShare = False
       'Else
'        GetShare = True
     'End If
 'End If
 
 'Set vbReg = Nothing
 
 'Exit Function
'REGERR:
  'GetShare = True
  'MsgBox "较对注册码错误:" & Err.Description, vbCritical
  'Exit Function
  
End Function

'加密的口令
Private Function SecretPWD(tmpPWD As String) As String

   On Error GoTo SeErr
   
  '将加密口令变回来
   Dim shiftStr As String, shiftStrR As Variant, shiftNum As Integer, ili As Integer, SureStr As String
       shiftStr = Trim(tmpPWD)
       shiftNum = Len(shiftStr)
      ili = 1
      SureStr = ""
        For ili = 1 To shiftNum
            shiftStrR = Mid(shiftStr, ili, 1)
            shiftStrR = Asc(shiftStrR)
            shiftStrR = shiftStrR - 3
            shiftStrR = Chr(shiftStrR)
            SureStr = SureStr & shiftStrR
        Next
   '密匙
   '开始查找 sureStr为解除的口令
    SecretPWD = SureStr
    
    Exit Function
SeErr:
   MsgBox "解密错误:" & Err.Description, vbCritical
   SureStr = tmpPWD
End Function