frmlogin.frm

银行、电信

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmLogin 
   AutoRedraw      =   -1  'True
   BorderStyle     =   1  'Fixed Single
   Caption         =   "登录窗口"
   ClientHeight    =   1830
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4380
   Icon            =   "frmLogin.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1830
   ScaleWidth      =   4380
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   375
      Left            =   3240
      TabIndex        =   3
      Top             =   1320
      Width           =   975
   End
   Begin VB.ComboBox cboUserTxt 
      BackColor       =   &H00FFFFFF&
      Height          =   300
      Left            =   1800
      TabIndex        =   0
      Text            =   "cboUserTxt"
      Top             =   480
      Width           =   2415
   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.CommandButton cmdOK 
      Caption         =   "确定(&O)"
      Height          =   375
      Left            =   2280
      TabIndex        =   2
      Top             =   1320
      Width           =   975
   End
   Begin MSComctlLib.StatusBar StatusBar1 
      Height          =   300
      Left            =   480
      TabIndex        =   4
      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        =   5
      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        =   6
      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        =   7
      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 m_strServer                 As String
Dim m_strDBName                 As String
Dim m_strUserName               As String
Dim m_strUserPassword           As String

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
    Unload Me
End Sub

Private Sub cmdOK_Click()
    On Error GoTo ERROR_EXIT
    Dim strUser As String, strPass As String
    Dim Leng As Integer, i As Integer, addFlag As Boolean
    Dim r As clsRegistry
    Dim sINIFile As String, sNextFile As String
    Dim Subkey As String, str1 As String
    
    Me.MousePointer = 11
    
    If Trim$(cboUserTxt.Text) = "" Then
        MsgBox "请输入登录用户名称！", vbOKOnly, "系统提示"
        Exit Sub
    End If
    strUser = cboUserTxt.Text
    strPass = txtPassword.Text
    m_strOld = strUser

    '对用户名和密码进行加密
    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
    
    m_strUserName = GetSysUserName        ' 参看 modDatabase 模块
    m_strUserPassword = GetSysPassword    ' 参看 modDatabase 模块
        
    '保存数据库连接信息
    dbDataConnectSet m_strUserName, m_strUserPassword, m_strDBName, m_strServer
    If Not OpenDB() Then GoTo ERROR_EXIT
    
    If Not UserConfirm() Then
        Me.MousePointer = 0
        Exit Sub
    End If
    
    '加入新用户
    Set r = New clsRegistry
    
    '保存INI文件
    addFlag = False
    If sINIFile = "" Then
        Subkey = g_strREG_SERVER_KEY
        sNextFile = r.GetValue(eHKEY_LOCAL_MACHINE, Subkey, "Path")
        sNextFile = RemoveNullChar(sNextFile)

        If sNextFile = "" Then
            sINIFile = App.Path & "\CyQueue.INI"
        Else
            AddDirSep sNextFile
            sINIFile = sNextFile & "CyQueue.INI"
        End If
        Set r = Nothing
    End If
    Leng = CInt(sGetINI(sINIFile, "User", "Count", 0))
    If Leng = 0 Then
        addFlag = True
    Else
        For i = 1 To Leng
            str1 = sGetINI(sINIFile, "Settings", "UserLogin" & i, "")
            '去掉多余的空格
            cboUserTxt.Text = str1
            str1 = cboUserTxt.Text
            If UCase(Trim$(str1)) = UCase(Trim$(m_strOld)) Then
                addFlag = True
                Exit For
            End If
        Next i
    End If
    
    If addFlag = False Then
        '写INI文件
        sWriteINI sINIFile, "User", "Count", CStr(Leng + 1)
        sWriteINI sINIFile, "Settings", "UserLogin" & (Leng + 1), m_strOld
    End If
    
    Unload Me
    frmSplash.Show
    frmSplash.MousePointer = 0
    
    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
    
    Unload Me
    Me.MousePointer = 0
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
        
    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_strDBName = sGetINI(sINIFile, "Server", "DateBase", "?")
    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 = ""
End Sub

Private Sub Form_Terminate()
    On Error Resume Next
    Set frmLogin = Nothing
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

'////////////////////////////////////////////////////////////////////////////////////////////
'验证登录数据库
Private Function UserConfirm() As Boolean
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset
    Dim strPassword As String, intCount As Integer
    
    rs.Open "Select * From QFUser Where ku_name = '" & Trim(cboUserTxt.Text) & _
            "'", dbMyDB, adOpenStatic, adLockReadOnly
    If rs.RecordCount < 0 Then
        GoTo ERROR_EXIT
    ElseIf rs.RecordCount > 1 Then
        GoTo ERROR_EXIT
    ElseIf rs.RecordCount = 0 Then
        intCount = 0
    ElseIf rs.RecordCount = 1 Then
        If Not IsNull(rs!ku_password) Then
            modCipher.Decipher "CoBeyond_Queue_Yixing", rs!ku_password, strPassword
            If txtPassword.Text <> strPassword Then
                intCount = 0
                GoTo ERROR_LOGIN
            End If
        Else
            If txtPassword.Text <> "" Then GoTo ERROR_LOGIN
        End If
        m_iUser = rs!ku_id
        intCount = 1
    End If
    
    rs.Close
    Set rs = Nothing
    
    UserConfirm = True
    Exit Function
ERROR_LOGIN:
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    MsgBox "您输入的用户名或用户密码不正确，请核对后重新输入！", vbOKOnly, "系统提示"
    txtPassword.Text = ""
    txtPassword.SetFocus
    UserConfirm = False
    Exit Function
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
    UserConfirm = False
End Function