frmlogin.frm

排队分诊管理系统源代码！该代码使用VB6开发环境

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmLogin 
   Caption         =   "服务人员登录"
   ClientHeight    =   1830
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4350
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   ScaleHeight     =   1830
   ScaleWidth      =   4350
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   375
      Left            =   3240
      TabIndex        =   3
      Top             =   1320
      Width           =   975
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定(&O)"
      Height          =   375
      Left            =   2280
      TabIndex        =   2
      Top             =   1320
      Width           =   975
   End
   Begin VB.CommandButton cmdSet 
      Caption         =   "设置(&S)"
      Height          =   375
      Left            =   120
      TabIndex        =   4
      Top             =   1320
      Width           =   975
   End
   Begin VB.TextBox txtPassword 
      BackColor       =   &H00FFFFFF&
      Height          =   300
      IMEMode         =   3  'DISABLE
      Left            =   1800
      MaxLength       =   18
      PasswordChar    =   "*"
      TabIndex        =   1
      Top             =   840
      Width           =   2415
   End
   Begin VB.ComboBox cboUserTxt 
      BackColor       =   &H00FFFFFF&
      Height          =   300
      Left            =   1800
      TabIndex        =   0
      Text            =   "cboUserTxt"
      Top             =   480
      Width           =   2415
   End
   Begin MSComctlLib.StatusBar StatusBar1 
      Height          =   300
      Left            =   480
      TabIndex        =   6
      Top             =   120
      Width           =   1215
      _ExtentX        =   2143
      _ExtentY        =   529
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Bevel           =   2
            Text            =   "数据服务器："
            TextSave        =   "数据服务器："
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.StatusBar StatusBar3 
      Height          =   300
      Left            =   480
      TabIndex        =   8
      Top             =   840
      Width           =   1215
      _ExtentX        =   2143
      _ExtentY        =   529
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Bevel           =   2
            Text            =   "用户密码："
            TextSave        =   "用户密码："
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.StatusBar StatusBar4 
      Height          =   300
      Left            =   480
      TabIndex        =   7
      Top             =   480
      Width           =   1215
      _ExtentX        =   2143
      _ExtentY        =   529
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Bevel           =   2
            Text            =   "用户工号："
            TextSave        =   "用户工号："
         EndProperty
      EndProperty
   End
   Begin VB.Label lblServer 
      BackColor       =   &H80000009&
      BorderStyle     =   1  'Fixed Single
      Height          =   300
      Left            =   1800
      TabIndex        =   5
      Top             =   120
      Width           =   2415
   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 m_tagErrInfo                As TYPE_ERRORINFO       '错误信息

Dim mhBaseCursor As Long, mhAniCursor As Long
Dim m_bCancel                   As Boolean              '是否退出

Private Sub cboUserTxt_GotFocus()
    On Error Resume Next
    cboUserTxt.BackColor = &H80000018
End Sub

Private Sub cboUserTxt_KeyPress(KeyAscii As Integer)
    On Error Resume Next
    If KeyAscii = 13 Then  '是回车键？
    KeyAscii = 0 '0取消输入
    SendKeys "{tab}"
    End If
End Sub

Private Sub cboUserTxt_LostFocus()
    On Error Resume Next
    cboUserTxt.BackColor = &H80000005
End Sub

Private Sub cmdCancel_Click()
    On Error Resume Next
    m_bCancel = True
    Unload Me
End Sub

Private Sub cmdOK_Click()
    On Error GoTo ERROR_EXIT
    Dim strUser As String
    Dim strPass As String
    Dim lResult As Long
    
    If Trim$(cboUserTxt.Text) = "" Then
        MsgBox "请输入用户工号！", vbOKOnly, "系统提示"
        Exit Sub
    End If
    strUser = cboUserTxt.Text
    strPass = txtPassword.Text
    m_strOld = strUser
    
    '修改鼠标
    mhAniCursor = LoadCursorFromFile(App.Path & "\hourglas.ani")
    lResult = SetClassLong((cmdOK.hWnd), GCL_HCURSOR, mhAniCursor)
    
    '对用户名和密码进行加密
    m_strUser = ""
    modCipher.Cipher "CoBeyond_Queue_Yixing", strUser, m_strUser
    If Trim$(strPass) <> "" Then
        m_strPass = ""
        modCipher.Cipher "CoBeyond_Queue_Yixing", strPass, m_strPass
    Else
        m_strPass = ""
    End If
    
    If frmQueue.Visible = True Then
        Unload frmQueue
    End If
    '装载主显示程序
    Load frmQueue
    
    If frmQueue.m_bConnect = True Then
        '修改鼠标
        lResult = SetClassLong((cmdOK.hWnd), GCL_HCURSOR, mhBaseCursor)
        lResult = DestroyCursor(mhAniCursor)
        
        m_bLogin = True
        m_bCancel = False
        Unload Me
    Else
        MsgBox "无法连接到中心控制台！", vbOKOnly + vbCritical, "系统错误"
        m_bLogin = False
        Unload frmQueue
        
        '修改鼠标
        lResult = SetClassLong((cmdOK.hWnd), GCL_HCURSOR, mhBaseCursor)
        lResult = DestroyCursor(mhAniCursor)
    End If
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmLogin"
    m_tagErrInfo.strErrFunc = "cmdOK_Click"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    lResult = SetClassLong((cmdOK.hWnd), GCL_HCURSOR, mhBaseCursor)
    lResult = DestroyCursor(mhAniCursor)
End Sub

Private Sub cmdSet_Click()
    On Error GoTo ERROR_EXIT
    Dim dlg As frmSet
    
    Set dlg = New frmSet
    Me.Hide
    
    dlg.Show vbModal, frmLogin
    If dlg.m_bCancel = False Then
        m_strServer = dlg.m_sServerName
        m_iPort = dlg.m_iServerPort
    End If
    Set dlg = Nothing
    lblServer.Caption = m_strServer
    
    Me.Show
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmLogin"
    m_tagErrInfo.strErrFunc = "cmdSet_Click"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    Me.Show
End Sub

Private Sub Form_Load()
    On Error GoTo ERROR_EXIT
    Dim strLogFile As String, dFileLen As Double
    Dim sINIFile As String, sNextFile As String
    Dim Subkey As String
    Dim Leng As Integer, i As Integer
    Dim r As clsRegistry
    
    m_bCancel = False
    mhBaseCursor = GetClassLong((hWnd), GCL_HCURSOR)
    
    Set r = New clsRegistry
    
    lblServer.Caption = ""
    cboUserTxt.Clear
    txtPassword.Text = ""

    Subkey = g_strREG_SERVER_KEY
    sNextFile = r.GetValue(eHKEY_LOCAL_MACHINE, Subkey, "Path")
    sNextFile = RemoveNullChar(sNextFile)
    If sNextFile = "" Then
        sINIFile = App.Path & "\CyQueue.INI"
        SetErrorLogFile App.Path
    Else
        AddDirSep sNextFile
        sINIFile = sNextFile & "CyQueue.INI"
        
        strLogFile = r.GetValue(eHKEY_LOCAL_MACHINE, g_strREG_SERVER_KEY, "Logfile")
        dFileLen = CDbl(r.GetValue(eHKEY_LOCAL_MACHINE, g_strREG_SERVER_KEY, "Logsize"))
        If strLogFile = "" Then
            SetErrorLogFile sNextFile
        Else
            SetErrorLogFile sNextFile, strLogFile, dFileLen / 1024
        End If
    End If

    '检查服务器名和端口号
    m_strServer = sGetINI(sINIFile, "Server", "ServerName", "?")
    m_iPort = CInt(sGetINI(sINIFile, "Server", "ServerPort", "?"))
    lblServer.Caption = m_strServer
    
    Leng = CInt(sGetINI(sINIFile, "User", "Count", 0))
    If Leng = 0 Then GoTo ERROR_EXIT
    ReDim strServer(Leng - 1)
    For i = 1 To Leng
        cboUserTxt.AddItem sGetINI(sINIFile, "Settings", "UserLogin" & i, "?")
    Next i
    'select the first item
    If cboUserTxt.ListCount > 0 Then cboUserTxt.ListIndex = 0
    
    Me.Show
    txtPassword.SetFocus
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmLogin"
    m_tagErrInfo.strErrFunc = "Form_Load"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    lblServer.Caption = ""
    cboUserTxt.Clear
    txtPassword.Text = ""
    cmdSet_Click
End Sub

Private Sub Form_Terminate()
    On Error Resume Next
    Set frmLogin = Nothing
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    If m_bCancel = False Then
        frmQueue.Show
        Set frmLogin = Nothing
    End If
End Sub

Private Sub txtPassword_GotFocus()
    On Error Resume Next
    txtPassword.BackColor = &H80000018
End Sub

Private Sub txtPassword_KeyPress(KeyAscii As Integer)
    On Error Resume Next
    If KeyAscii = 13 Then  '是回车键？
    KeyAscii = 0 '0取消输入
    SendKeys "{tab}"
    End If
End Sub

Private Sub txtPassword_LostFocus()
    On Error Resume Next
    txtPassword.BackColor = &H80000005
End Sub