frmlogin.frm

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

         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Index           =   1
      Left            =   840
      TabIndex        =   5
      Top             =   630
      Width           =   840
   End
   Begin VB.Shape Shape1 
      BorderColor     =   &H00E0E0E0&
      FillColor       =   &H80000000&
      FillStyle       =   0  'Solid
      Height          =   510
      Left            =   165
      Top             =   930
      Width           =   3765
   End
End
Attribute VB_Name = "frmLogin"
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
    
   '检查密码的正确性
    Dim x As Long
        x = UserTxt.ListIndex
   '用户名为空时,退出
    If UserTxt.Text = "" Then
       MsgBox "用户名与口密不能为空。  ", vbInformation
       txtPassword.SetFocus
       Exit Sub
    End If
   '开始查找 sureStr为解除的口令
   '检查权限
    If frmMain.CheckLogin(Trim(UserTxt.Text), Trim(txtPassword.Text)) = True Then
       Logined = True
       UserText = UserTxt.Text
       Unload Me
       Exit Sub
    Else
        If LOGINNO > 2 Then
           MsgBox "对不起，您不能使用该系统！", 64, "登录失败"
           Logined = False
           Unload Me
           Exit Sub
        End If
        MsgBox "无效的密码，再试一次！", 32, "登录"
        LOGINNO = LOGINNO + 1
        txtPassword.SetFocus
        SendKeys "{Home}+{End}"
    End If
    
    Exit Sub
LoadERR:
     MsgBox "对不起,系统启动错误:" & Err.Description, vbCritical
     
End Sub

Private Sub Form_Activate()

  On Error Resume Next
  txtPassword.SetFocus
  
End Sub

Private Sub Form_Load()

   On Error GoTo LoadERR

   GetFormSet Me, Screen
   Screen.MousePointer = 11

   If Right(App.Path, 1) = "\" Then
     SystemConfigFile = App.Path & "System.ini"
    Else
     SystemConfigFile = App.Path & "\System.ini"
   End If
   
   Dim fIni As RegClass
   Set fIni = New RegClass
     
   Dim sTMp As String, sLogin As String, sPWD As String
    
   XLeft = fIni.ReadINIString("System", "xLeft", "0", SystemConfigFile)
   XTop = fIni.ReadINIString("System", "xTop", "0", SystemConfigFile)
   xSmallLeft = fIni.ReadINIString("System", "xSmallLeft", "0", SystemConfigFile)
   xSmallTop = fIni.ReadINIString("System", "xSmallTop", "0", SystemConfigFile)
   nPrintLine = fIni.ReadINIString("System", "PrintLine", 11, SystemConfigFile)
  '给出系统配置的时间段
   Lunch1 = fIni.ReadINIString("DatePart", "Lunch1", "10", SystemConfigFile)
   Lunch2 = fIni.ReadINIString("DatePart", "Lunch2", "14", SystemConfigFile)
   Supper1 = fIni.ReadINIString("DatePart", "Supper1", "14", SystemConfigFile)
   Supper2 = fIni.ReadINIString("DatePart", "Supper2", "18", SystemConfigFile)
   Night1 = fIni.ReadINIString("DatePart", "Night1", "18", SystemConfigFile)
   NIght2 = fIni.ReadINIString("DatePart", "Night2", "23", SystemConfigFile)
  '给出公司信息
   sCompanyTel = fIni.ReadINIString("System", "Tel", "", SystemConfigFile)
   sCompanyAdd = fIni.ReadINIString("System", "Add", "", SystemConfigFile)
   sUnit = fIni.ReadINIString("System", "CompanyName", "", SystemConfigFile)
  '落单后删除预订内容
   DeletePre = CBool(fIni.ReadINIString("System", "DeletePre", 0, SystemConfigFile))
   Dim tmpPoint As Long
       tmpPoint = 0
   If sUnit <> "" Then
      tmpPoint = InStr(1, sUnit, Chr(0), vbTextCompare)
      If tmpPoint > 1 Then
         sUnit = Left(sUnit, tmpPoint - 1)
      End If
   End If
   If sCompanyTel <> "" Then
      tmpPoint = InStr(1, sCompanyTel, Chr(0), vbTextCompare)
      If tmpPoint > 1 Then
         sCompanyTel = Left(sCompanyTel, tmpPoint - 1)
      End If
   End If
   If sCompanyAdd <> "" Then
      tmpPoint = InStr(1, sCompanyAdd, Chr(0), vbTextCompare)
      If tmpPoint > 1 Then
         sCompanyAdd = Left(sCompanyAdd, tmpPoint - 1)
      End If
   End If
   sInfo = fIni.ReadINIString("System", "Info", "欢迎光临〖新开元大酒店〗", SystemConfigFile)
   sContact = fIni.ReadINIString("System", "Contact", "0512-51565209，13701576622", SystemConfigFile)
   sWeb = fIni.ReadINIString("System", "Web", "网维网络软件有限公司", SystemConfigFile)
   IsAutorun = CInt(fIni.ReadINIString("System", "AutoRun", "0", SystemConfigFile))
   NoTitle = CBool(fIni.ReadINIString("System", "NoTitle", "0", SystemConfigFile))
   
  '将标题改变
   Me.Caption = sInfo
   
  'SQL数据库配置
   IsSqlDat = CBool(fIni.ReadINIString("System", "IsSQL", "0", SystemConfigFile))
   SQLServer = fIni.ReadINIString("System", "SQLServer", "", SystemConfigFile)
   SQLUser = fIni.ReadINIString("System", "SQLUser", "", SystemConfigFile)
   SQLPWD = fIni.ReadINIString("System", "SQLpwd", "", SystemConfigFile)
   
  '给出ACCESS数据库文件
   If IsSqlDat = True Then
        If SQLServer = "" Or SQLUser = "" Or SQLPWD = "" Then
           MsgBox "SQL服务器配置不完整,系统自动启动Access版。   ", vbInformation
           IsSqlDat = False
        End If
   End If
   If IsSqlDat = True Then
        Constr = "Provider=SQLOLEDB.1;User ID=" & SQLUser & ";Password=" & SQLPWD & ";Persist Security Info=True;Server=" & SQLServer & ";Database=Eatery"
     Else
        AccessFile = fIni.ReadINIString("system", "AccessDatabase", App.Path & "\SystemData.mdb", SystemConfigFile)
        GetAccessFile AccessFile
        'Constr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessFile & ";Mode=ReadWrite;Persist Security Info=False"
        Constr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessFile & ";Mode=ReadWrite;Persist Security Info=False;Jet OLEDB:Database Password=new_nand!ok"
   End If
   
   Set fIni = Nothing
    
  '屏蔽所有菜单
   frmMain.CheckAuthor False
  
  '写入操作员列表
   WriteEmploy
   
    If UserTxt.ListCount > 0 Then
       UserTxt.ListIndex = 0
    End If

    Screen.MousePointer = 0
    LOGINNO = 1
    ShowIt Me.Hwnd

Exit Sub
LoadERR:
   Screen.MousePointer = 0
   MsgBox "系统启动错误:" & Err.Description & vbCrLf & vbCrLf & "请直接与开发商联系:0512-51565209", 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