frmcheckuser.frm

用VB 和SQL SERVER 2000做的存取检验系统

VERSION 5.00
Begin VB.Form frmCheckUser 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "用户验证"
   ClientHeight    =   3150
   ClientLeft      =   3090
   ClientTop       =   4425
   ClientWidth     =   5370
   Icon            =   "frmCheckUser.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3150
   ScaleWidth      =   5370
   ShowInTaskbar   =   0   'False
   Begin VB.TextBox txtFType 
      Height          =   375
      Left            =   2160
      TabIndex        =   10
      Top             =   1920
      Width           =   2055
   End
   Begin VB.Frame Frame1 
      Caption         =   "访问类型"
      Height          =   855
      Left            =   840
      TabIndex        =   6
      Top             =   120
      Width           =   3855
      Begin VB.OptionButton optLoginType 
         Caption         =   "更新修改"
         Height          =   375
         Index           =   1
         Left            =   2160
         TabIndex        =   8
         Top             =   240
         Width           =   1215
      End
      Begin VB.OptionButton optLoginType 
         Caption         =   "查询"
         Height          =   375
         Index           =   0
         Left            =   600
         TabIndex        =   7
         Top             =   240
         Width           =   975
      End
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定(O)"
      Default         =   -1  'True
      Height          =   375
      Left            =   720
      TabIndex        =   2
      Top             =   2400
      Width           =   1335
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   375
      Left            =   3240
      TabIndex        =   3
      Top             =   2400
      Width           =   1335
   End
   Begin VB.TextBox txtUID 
      Height          =   270
      Left            =   2160
      TabIndex        =   0
      Top             =   1200
      Width           =   2055
   End
   Begin VB.TextBox txtPWD 
      Height          =   270
      IMEMode         =   3  'DISABLE
      Left            =   2160
      PasswordChar    =   "*"
      TabIndex        =   1
      Top             =   1560
      Width           =   2055
   End
   Begin VB.Label Label3 
      Caption         =   "文件类型："
      Height          =   375
      Left            =   1200
      TabIndex        =   9
      Top             =   2040
      Width           =   975
   End
   Begin VB.Image Image1 
      Height          =   480
      Left            =   360
      Picture         =   "frmCheckUser.frx":058A
      Top             =   1440
      Width           =   480
   End
   Begin VB.Label Label2 
      Caption         =   "口令："
      Height          =   255
      Left            =   1200
      TabIndex        =   5
      Top             =   1660
      Width           =   975
   End
   Begin VB.Label Label1 
      Caption         =   "用户名："
      Height          =   255
      Left            =   1200
      TabIndex        =   4
      Top             =   1200
      Width           =   975
   End
End
Attribute VB_Name = "frmCheckUser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit
Public gValidUser As Boolean
Public gUserCount As Integer
Public gCurUserPWD  As String

Private Sub cmdCancel_Click()
    g_Database = ""
    gValidUser = False
    gCurUser = ""
    Unload Me
    frmMenu.Show
    frmMsg.Hide
End Sub

Private Sub cmdOK_Click()
Dim temUID As String
Dim temPWD As String
Dim sErr As String
Dim i As Integer
Dim bCheck As Boolean
    temUID = txtUID.Text
    temPWD = txtPWD.Text
    Unload frmMsg
    gMsgShow = True
    frmMsg.Show
    sErr = ""
    bCheck = False
    For i = 0 To 1
        If optLoginType(i).Value Then
            If i = 0 Then
                gFileAccess = "FDeny"
            End If
            If i = 1 Then
               gFileAccess = "FQuery"
            End If
            gAccessFileType = optLoginType(i).Caption
            bCheck = True
            Exit For
        End If
    Next i
    If Not bCheck Then
        MsgBox "请先选择文件类型！", vbOKOnly, "提示"
        Exit Sub
    End If
    If Trim(txtFType.Text) = "" Then
        MsgBox "请输入访问文件的类型！", vbOKOnly + vbExclamation, "系统提示"
        Exit Sub
    End If
    If CheckValidUser(temUID, temPWD, sErr) Then
        gCurUser = temUID
        gCurUserPWD = temPWD
        gValidUser = True
        Unload Me
        frmMain.Show
    Else
        MsgBox "错误，口令不正确或无权访问,请重新输入！", vbOKOnly + vbExclamation, "提示"
        If txtUID.Enabled Then txtUID.SetFocus
    End If
End Sub


Private Sub Form_Activate()
   ConnectServer
    If Not (gbConnected Or gValidUser) Then
        MsgBox "没有打开数据库，请检查用户和密码！", vbOKOnly, "系统提示"
        Exit Sub  'End
    End If
    gMsgShow = False
End Sub


Private Sub Form_Load()
    frmMsg.Show
End Sub

Private Sub txtPWD_GotFocus()
    With txtPWD
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
End Sub

Private Sub txtUID_GotFocus()
    With txtUID
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
End Sub



Function CheckValidUser(ByRef vUID As String, ByRef vPWD As String, ByRef vErr As String) As Boolean
Dim rcUsers As ADODB.Recordset
Dim strSQL  As String
Dim temPWD As String
Dim temRole As String
Dim aRole() As String
Dim gSQL_UPPER As String
Dim i As Integer
Dim FType() As String
    gSQL_UPPER = ""
    gRInput = False
    gRQuery = False
    gRAdmin = False
    gRExt = False
    CheckValidUser = False
    strSQL = "SELECT * FROM UserLogin WHERE " & gSQL_UPPER & "(UID)='" & UCase(Trim(vUID)) & "' "
    Set rcUsers = New ADODB.Recordset
    On Error GoTo err_OpenUsers
    rcUsers.Open strSQL, SYS_Cnn, adOpenDynamic, adLockOptimistic, adCmdText
    On Error GoTo 0
    temPWD = ""
    temRole = ""
    If rcUsers.EOF Then vErr = "用户名或口令错误!"
    Do Until rcUsers.EOF
        If Not IsNull(rcUsers!PWD) Then
            temPWD = Trim(rcUsers!PWD)
        End If
        If temPWD <> UCase(vPWD) Then
            vErr = "用户名或口令错误!"
        Else
            If Not IsNull(rcUsers!Role) Then
                temRole = Trim(rcUsers!Role)
            End If
            temRole = Replace(temRole, "，", ",")
            aRole = Split(temRole, ",")
            For i = 0 To UBound(aRole)
                Select Case aRole(i)
                     Case USER_INPUT
                        gRInput = True
                        CheckValidUser = True
                     Case USER_QUERY
                        gRQuery = True
                        CheckValidUser = True
                     Case USER_ADMIN
                        gRAdmin = True
                        CheckValidUser = True
                     Case USER_EXT
                        gRExt = True
                        CheckValidUser = True
                     Case Else
                End Select
            Next i
            Select Case gFileAccess
                Case "FQuery"
                    gFileType = Trim(rcUsers!FQuery)
                Case "FEdit"
                    gFileType = Trim(rcUsers!FEdit)
                Case Else
                    gFileType = Trim(rcUsers!FDeny)

            End Select
            FType = Split(Trim(txtFType.Text), ",")
            For i = 0 To UBound(FType)
                If InStr(1, gFileType, UCase(FType(i)), vbTextCompare) > 0 Then
                    MsgBox "恭喜，你已经通过检验！", vbOKOnly + vbExclamation, "提示"
                Else
                    CheckValidUser = False
                End If
            Next i
            If CheckValidUser Then Exit Do
            vErr = "没有足够的权限!"
        End If
        rcUsers.MoveNext
    Loop
    Exit Function
err_OpenUsers:
    Exit Function
End Function