frmboxlogin.frm

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

Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim LOGINNO As Integer        '登录次数

Private Sub cmdCancel_Click()
       
    Logined = False
    Me.Hide
    
End Sub

Private Sub cmdOK_Click()
    
    On Error GoTo LoadERR

   '用户名为空时,退出
    If UserTxt.Text = "" Then
       MsgBox "工号与口密不能为空。  ", vbInformation
       txtPassword.SetFocus
       Exit Sub
    End If
   '开始查找 sureStr为解除的口令
   '检查权限
    If CheckBoxLogin(Trim(UserTxt.Text), Trim(txtPassword.Text)) = True Then
       frmBoxForm.LDUser = Trim(UserTxt.Text)
     Else
       frmBoxForm.LDUser = ""
    End If
    
    Unload Me
    
    Exit Sub
LoadERR:
     MsgBox "对不起,验证密码错误:" & Err.Description, vbCritical
     
End Sub

'加密的口令
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

Private Function CheckBoxLogin(sID As String, sPWD As String) As Boolean
 
    On Error GoTo GetERR
    
    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
          CheckBoxLogin = False
          Exit Function
       End If
       
       vRS.Close
       vDB.Close
       Set vRS = Nothing
       Set vDB = Nothing
       CheckBoxLogin = True
          
    Exit Function
GetERR:
    CheckBoxLogin = False
    MsgBox "检测权限错误:" & Err.Description & vbCrLf _
      & "请检查数据库配置是否正确,否则通过其它配置来选择？  ", vbCritical
    
End Function

Private Sub Form_Activate()

  On Error Resume Next
  txtPassword.SetFocus
  
End Sub

Private Sub Form_Load()

   On Error GoTo LoadERR
   GetFormSet Me, Screen
 
  '写入操作员列表
   WriteEmploy
   
   If UserTxt.ListCount > 0 Then
      UserTxt.ListIndex = 0
   End If

   Exit Sub
LoadERR:
   Screen.MousePointer = 0
   MsgBox "请确认数据库配置是否正确,   " & Err.Description & vbCrLf _
      & "请在【其它配置】中选择 Access 数据库,然后重新启动本系统。 " _
      & vbCrLf & vbCrLf & "如果使用SQL数据库，请确认Login名与口令是否正确。", vbCritical, sContact
   Exit Sub

End Sub

Private Sub Form_Resize()

 On Error Resume Next
 If Me.WindowState = 1 Then Exit Sub
 If Me.WindowState = 2 Then Exit Sub
 
 Me.Width = 4245
 Me.Height = 2010
  
End Sub

Private Sub Form_Unload(Cancel As Integer)

  SaveFormSet Me

End Sub

Private Sub txtPassword_KeyPress(KeyAscii As Integer)

  On Error Resume Next
  If KeyAscii = 13 And UserTxt.Text <> "" Then
     cmdOK.Value = True
  End If
  
End Sub

Private Sub UserTxt_Click()
 
 SendKeys "{Tab}"
 
End Sub

'装载用户名称到登录窗口中
 Private Sub WriteEmploy()
   
      On Error GoTo WriteERR
      
      Dim cnDB As Connection
      Dim cnRS As Recordset
      Set cnDB = CreateObject("ADODB.Connection")
      Set cnRS = CreateObject("ADODB.Recordset")
          cnDB.Open Constr
      
       Dim sTmp As String, sID As String
                      
      '如果帐号已经过期、帐号已经锁定时将不显示,永不过期有效
       sTmp = "Select * from Main"
       cnRS.Open sTmp, cnDB, adOpenDynamic, adLockReadOnly, adCmdText
       
       If Not cnRS.EOF Then
          
          Do While Not cnRS.EOF
             If cnRS.EOF Then Exit Do
                sTmp = cnRS("操作员")
               '插入到列表中
                UserTxt.AddItem sTmp
                cnRS.MoveNext
          Loop
          
       End If
       
       cnRS.Close
       cnDB.Close
       Set cnRS = Nothing
       Set cnDB = Nothing
 
    Exit Sub
WriteERR:
    MsgBox "写操作员错误:" & Err.Description, vbCritical & vbCrLf _
       & "请确认是否是数据库没有配置好？   ", vbExclamation
  End Sub

'检查用户及密码是否正确
Private Function CheckUser(sUs As String, sPW As String) As Boolean
  
       On Error GoTo checkRRR
   
       Dim cnDB As Connection
       Dim cnRS As Recordset
       Dim sTmp As String, sName As String
     
       Set cnDB = CreateObject("ADODB.Connection")
       Set cnRS = CreateObject("ADODB.Recordset")
           cnDB.Open Constr
           
          '没有锁定，没有过期的用户,Author12为配方
           sTmp = "Select tbdAuthor.fldID,tbdHuman.fldName," _
             & "tbdAuthor.Author12,tbdAuthor.lgLockDate,tbdAuthor.lgLock,tbdAuthor.lgCount," _
             & "tbdAuthor.lgLockIP,tbdAuthor.ExpireDate,tbdAuthor.lgNever," _
             & "tbdHuman.fldName From tbdAuthor Inner Join tbdHuman On " _
             & "tbdAuthor.fldID=tbdHuman.fldID Where " _
             & " tbdAuthor.lgLock=0 And tbdAuthor.fldID='" & sUs & "' And tbdAuthor.fldPWD='" & sPW & "'" _
             & " And (tbdAuthor.Author12=-1 or tbdAuthor.Author12=1) And (tbdAuthor.ExpireDate>='" & Date & "' Or tbdAuthor.lgNever=1)"
 
            cnRS.Open sTmp, cnDB, adOpenStatic, adLockReadOnly, adCmdText
         
           '密码与用户不存在时，显示错误！
            If cnRS.EOF And cnRS.BOF Then
               CheckUser = False
              Else
               CheckUser = True
            End If
            
            cnRS.Close
            cnDB.Close
            Set cnRS = Nothing
            Set cnDB = Nothing
  
  Exit Function
  
checkRRR:
  MsgBox "检查用户名与密码错误:" & Err.Description, vbCritical
  CheckUser = False
End Function

'给出用户名
Private Function GetUserName(sTmpName As String) As String
  
   On Error Resume Next
   
   Dim nPos As Integer
      nPos = InStr(1, sTmpName, "|", vbTextCompare)
   If nPos > 0 Then
      GetUserName = Right(sTmpName, Len(sTmpName) - nPos)
    Else
      GetUserName = sTmpName
   End If
   
End Function

'给出用户ID
Private Function GetUserID(sTmpName As String) As String
  
   On Error Resume Next
   
   Dim nPos As Integer
      nPos = InStr(1, sTmpName, "|", vbTextCompare)
   If nPos > 0 Then
      GetUserID = Left(sTmpName, nPos - 1)
    Else
      GetUserID = sTmpName
   End If
  
End Function