frmlogin.frm

一个用于交警的系统

         Height          =   270
         Left            =   240
         TabIndex        =   4
         Top             =   480
         Width           =   3135
      End
      Begin VB.CommandButton cmdFoxproFile 
         Caption         =   "…"
         Height          =   255
         Left            =   3360
         TabIndex        =   5
         Top             =   480
         Width           =   375
      End
      Begin VB.Label lblFoxproFile 
         AutoSize        =   -1  'True
         Caption         =   "Foxpro 数据库文件"
         Height          =   180
         Left            =   240
         TabIndex        =   46
         Top             =   240
         Width           =   1530
      End
      Begin VB.Label lblFoxproUser 
         AutoSize        =   -1  'True
         Caption         =   "Foxpro 排序序列"
         Height          =   180
         Left            =   240
         TabIndex        =   45
         Top             =   960
         Width           =   1350
      End
   End
   Begin VB.Menu mnuLanguage 
      Caption         =   "语言 &L"
      Begin VB.Menu mnuChinese 
         Caption         =   "简体中文 &C"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuEnglish 
         Caption         =   "美国英语 &E"
      End
   End
   Begin VB.Menu mnuDatabase 
      Caption         =   "数据库 &D"
      Begin VB.Menu mnuAccess 
         Caption         =   "Access 数据库 &A"
      End
      Begin VB.Menu mnuSQLServer 
         Caption         =   "SQL Server 数据库 &S"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuOracle 
         Caption         =   "Oracle 数据库 &O"
      End
      Begin VB.Menu mnuFoxpro 
         Caption         =   "Foxpro 数据库 &F"
      End
      Begin VB.Menu mnuLine1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuOther 
         Caption         =   "其它数据库 &Q"
      End
   End
   Begin VB.Menu mnuOption 
      Caption         =   "选项 &O"
      Begin VB.Menu mnuRememberUser 
         Caption         =   "记住登录用户名 &U"
      End
      Begin VB.Menu mnuRememberPassword 
         Caption         =   "记住登录口令 &P"
      End
   End
End
Attribute VB_Name = "frmLogin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

'*** 本模块自定义的所有函数与过程 ************************
'Created by ZhangGuoSheng
'On 06-17-2001

'ClearAllContext()  清除所有控件内容
'ShowControlsSelected()  显示所选择的控件
'FormResize()  调整窗体大小
'FetchAllDSNs()  取出所有的数据源(DSN)
'*******************************************************

'*** 定义枚举常数 ***************************************
'Created by ZhangGuoSheng
'On 06-17-2001

Enum LoginUsedLanguage
    Chinese = 1
    English = 0
End Enum

Enum LoginUsedDatabase
    AccessDatabase = 0
    SQLServerDatabase = 1
    OracleDatabase = 2
    FoxproDatabase = 3
    OtherDatabase = 4
End Enum

'*******************************************************

'*** 定义公用(传递)变量 *********************************
'Created by ZhangGuoSheng
'On 06-17-2001

Public LanguageUsed As LoginUsedLanguage
Public DatabaseUsed As LoginUsedDatabase
Public UserConnection As New ADODB.Connection

'*******************************************************

'*** API 函数定义 ***************************************
'Created by ZhangGuoSheng
'On 06-17-2001
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Declare Function SQLDataSources Lib "ODBC32.DLL" (ByVal henv&, ByVal fDirection%, ByVal szDSN$, ByVal cbDSNMax%, pcbDSN%, ByVal szDescription$, ByVal cbDescriptionMax%, pcbDescription%) As Integer
Private Declare Function SQLAllocEnv% Lib "ODBC32.DLL" (env&)
Const SQL_SUCCESS As Long = 0
Const SQL_FETCH_NEXT As Long = 1

'********************************************************

'*** 其它变量和常数的定义 ********************************
'Created by ZhangGuoSheng
'On 06-17-2001

Dim FormChangeSize As Boolean
Dim FormHeight As Long
Dim FormWidth As Long

'*** 清除所有控件内容 ************************************
'Created by ZhangGuoSheng
'On 06-17-2001

Private Sub ClearAllContext()
    Dim ctl As Control
    
    On Error Resume Next
    For Each ctl In Controls
        If TypeOf ctl Is TextBox Then ctl = vbNullString
        If TypeOf ctl Is ComboBox Then
            ctl.Text = ""
            ctl.Clear
        End If
    Next
    
End Sub

'*** 显示所选择的控件 ************************************
'Created by ZhangGuoSheng
'On 06-17-2001

Private Sub ShowControlsSelected(ByVal DatabaseSelected As LoginUsedDatabase, Optional HasBeenLogin As Boolean = True)
    On Error Resume Next
    
    DatabaseUsed = DatabaseSelected
    
    fAccess.Visible = False
    fSQLServer.Visible = False
    fOracle.Visible = False
    fFoxpro.Visible = False
    fDSN.Visible = False
    pCmdButton.Visible = False
    
    fUserLogin.Visible = False
    
    mnuAccess.Checked = False
    mnuSQLServer.Checked = False
    mnuOracle.Checked = False
    mnuFoxpro.Checked = False
    mnuOther.Checked = False
    
    mnuChinese.Checked = False
    mnuEnglish.Checked = False
    
    fAccess.Enabled = False
    fSQLServer.Enabled = False
    fOracle.Enabled = False
    fFoxpro.Enabled = False
    fDSN.Enabled = False
    fUserLogin.Enabled = False
    
    If HasBeenLogin = True Then
        fUserLogin.Visible = True
        fUserLogin.Enabled = True
        mnuOption.Enabled = True
    Else
        pCmdButton.Visible = True
        mnuOption.Enabled = False
        
        Select Case DatabaseSelected
        Case AccessDatabase
            fAccess.Visible = True
            fAccess.Enabled = True
        Case SQLServerDatabase
            fSQLServer.Visible = True
            fSQLServer.Enabled = True
        Case OracleDatabase
            fOracle.Visible = True
            fOracle.Enabled = True
        Case FoxproDatabase
            fFoxpro.Visible = True
            fFoxpro.Enabled = True
        Case OtherDatabase
            fDSN.Visible = True
            fDSN.Enabled = True
        End Select
    End If
    
    Select Case DatabaseSelected
    Case AccessDatabase
        mnuAccess.Checked = True
    Case SQLServerDatabase
        mnuSQLServer.Checked = True
    Case OracleDatabase
        mnuOracle.Checked = True
    Case FoxproDatabase
        mnuFoxpro.Checked = True
    Case OtherDatabase
        mnuOther.Checked = True
    End Select
    
    If LanguageUsed = English Then
        mnuEnglish.Checked = True
    Else
        mnuChinese.Checked = True
    End If
    Refresh
    
End Sub

'*** 调整窗体大小 ****************************************
'Created by ZhangGuoSheng
'On 06-17-2001

Private Sub FormResize(Optional HasBeenLogin As Boolean = True)
    On Error Resume Next
    Dim lngHeight As Long
    
    If Me.WindowState = 1 Or Me.WindowState = 2 Then Exit Sub
    If Me.mnuDatabase.Visible = True Or Me.mnuLanguage.Visible = True Then
        lngHeight = 1250
    Else
        lngHeight = 1000
    End If
    FormChangeSize = True
    If HasBeenLogin = False Then
        If DatabaseUsed = AccessDatabase Then Me.Height = (fAccess.Top + fAccess.Height + lngHeight)
        If DatabaseUsed = SQLServerDatabase Then Me.Height = (fSQLServer.Top + fSQLServer.Height + lngHeight)
        If DatabaseUsed = OracleDatabase Then Me.Height = (fOracle.Top + fOracle.Height + lngHeight)
        If DatabaseUsed = FoxproDatabase Then Me.Height = (fFoxpro.Top + fFoxpro.Height + lngHeight)
        If DatabaseUsed = OtherDatabase Then Me.Height = (fDSN.Top + fDSN.Height + lngHeight)
        
        Me.Width = 6045
    Else
        Me.Height = (fUserLogin.Top + fUserLogin.Height + lngHeight)
        Me.Width = 4710
    End If
    
    FormWidth = Me.Width
    FormHeight = Me.Height
    FormChangeSize = False
End Sub

'*** 取出所有的数据源(DSN) *********************************
'Created by ZhangGuoSheng
'On 06-17-2001

Private Sub FetchAllDSNs()
    Dim i As Integer
    Dim sDSNItem As String * 1024
    Dim sDRVItem As String * 1024
    Dim sDSN As String
    Dim sDRV As String
    Dim iDSNLen As Integer
    Dim iDRVLen As Integer
    Dim lHenv As Long         'handle to the environment

    On Error Resume Next
    cboDSNList.Clear

    'get the DSNs
    If SQLAllocEnv(lHenv) <> -1 Then
        Do Until i <> SQL_SUCCESS
            sDSNItem = Space$(1024)
            sDRVItem = Space$(1024)
            i = SQLDataSources(lHenv, SQL_FETCH_NEXT, sDSNItem, 1024, iDSNLen, sDRVItem, 1024, iDRVLen)
            sDSN = Left$(sDSNItem, iDSNLen)
            sDRV = Left$(sDRVItem, iDRVLen)
                
            If sDSN <> Space(iDSNLen) Then
                cboDSNList.AddItem sDSN
            End If
        Loop
    End If

End Sub

'*** 建立数据库连接 ***************************************
'Created by ZhangGuoSheng
'On 06-17-2001

Private Function CreateConnection(Optional DatabaseSelected As LoginUsedDatabase = SQLServerDatabase, Optional strDSN As String, Optional strUserName As String, Optional strPassword As String, Optional strOther As String) As Boolean
    Dim strProvider As String
    
    On Error GoTo ErrMsg
    If LanguageUsed = Chinese Then
        ShowText "正在进行数据库连接 ..."
    Else
        ShowText "Connecting database ..."
    End If
    
    Screen.MousePointer = 11
    Select Case DatabaseSelected
    Case AccessDatabase
        strProvider = "Provider=Microsoft.Jet.OLEDB.4.0;Password=" & Trim(strPassword) & ";User ID=" & Trim(strUserName) & ";Data Source=" & Trim(strDSN) & ";Persist Security Info=True"
    Case SQLServerDatabase
        strProvider = "Provider=SQLOLEDB.1;Password=" & Trim(strPassword) & ";Persist Security Info=True;User ID=" & Trim(strUserName) & ";Initial Catalog=" & Trim(strOther) & ";Data Source=" & Trim(strDSN)
    Case OracleDatabase
        strProvider = "Provider=MSDAORA.1;Password=" & Trim(strPassword) & ";User ID=" & Trim(strUserName) & ";Data Source=" & Trim(strDSN) & ";Persist Security Info=True"
    Case FoxproDatabase
        strProvider = "Provider=VFPOLEDB.1;Data Source=" & Trim(strDSN) & ";Password=;Collating Sequence=" & Trim(strOther)
    Case OtherDatabase
        strProvider = "Provider=MSDASQL.1;Password=" & Trim(strPassword) & ";Persist Security Info=True;User ID=" & Trim(strUserName) & ";Data Source=" & Trim(strDSN) & ";Initial Catalog=" & Trim(strOther)
    End Select
    
    With UserConnection
        If .State <> 0 Then .Close
        .CursorLocation = adUseClient
        .Open strProvider
        If .State = 1 Then
            CreateConnection = True 'Open successfully
            
            If LanguageUsed = Chinese Then
                ShowText "数据库连接成功"
            Else
                ShowText "Connection successful"
            End If
        Else
            CreateConnection = False
            Set UserConnection = Nothing 'Opening fails
            
            If LanguageUsed = Chinese Then
                ShowText "数据库连接失败"
            Else
                ShowText "Connection Fails"
            End If
        End If
    End With
    Screen.MousePointer = 0
    Exit Function
    
ErrMsg:
    Screen.MousePointer = 0
    CreateConnection = False
    Set UserConnection = Nothing
    Call ShowErrorMessage
End Function

'*** 检查用户身份 ***************************************
'Created by ZhangGuoSheng
'On 06-17-2001

Private Function CheckUserAndPassword(ByVal cn As ADODB.Connection, ByVal tblName As String, ByVal fldUserName As String, ByVal fldPassword As String) As Boolean
    On Error GoTo ErrMsg
    
    Dim rsNewUser As New ADODB.Recordset
    Dim strPassword As String
    Dim strSQL As String
    
    CheckUserAndPassword = False
    If cn = "" Then
        Screen.MousePointer = 0
        If LanguageUsed = Chinese Then
            MsgBox "当前连接无效,不能完成当前操作!", vbExclamation + vbOKOnly, "系统信息"
        Else
            MsgBox "Connection fails,exit application!", vbExclamation + vbOKOnly, "System Message"
        End If
        Unload Me
        Exit Function
    End If
    If cn Is Nothing Then
        Screen.MousePointer = 0
        If LanguageUsed = Chinese Then
            MsgBox "当前连接无效,不能完成当前操作!", vbExclamation + vbOKOnly, "系统信息"
        Else
            MsgBox "Connection fails,exit application!", vbExclamation + vbOKOnly, "System Message"
        End If
        Unload Me
        Exit Function
    End If
    If cn.State = 0 Then
        Screen.MousePointer = 0
        If LanguageUsed = Chinese Then
            MsgBox "当前连接无效,不能完成当前操作!", vbExclamation + vbOKOnly, "系统信息"
        Else
            MsgBox "Connection fails,exit application!", vbExclamation + vbOKOnly, "System Message"
        End If
        Unload Me
        Exit Function
    End If

    If Trim(tblName) = vbNullString Or Trim(fldUserName) = vbNullString Or Trim(fldPassword) = vbNullString Then
        Screen.MousePointer = 0
        If LanguageUsed = Chinese Then
            MsgBox "对数据库访问时,缺乏相关信息,不能完成当前操作!", vbExclamation + vbOKOnly, "系统信息"
        Else
            MsgBox "Lack of parameter,please exit application!", vbExclamation + vbOKOnly, "System Message"
        End If
        Exit Function
    End If
    If Trim(txtUserName) = vbNullString Then 'If user don't input user name
        If LanguageUsed = Chinese Then
            MsgBox "请输入用户名称!", vbExclamation + vbOKOnly, "系统信息"
        Else
            MsgBox "Please input user name!", vbExclamation + vbOKOnly, "System Message"
        End If
        With txtUserName
            .SelStart = 0
            .SelLength = Len(.Text)
            
            On Error GoTo SFErrMsg
            .SetFocus
            On Error GoTo ErrMsg

        End With