frmaskuser.frm

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

VERSION 5.00
Begin VB.Form frmAskUser 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "用户注册"
   ClientHeight    =   1635
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5085
   Icon            =   "frmAskUser.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1635
   ScaleWidth      =   5085
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定(O)"
      Default         =   -1  'True
      Height          =   375
      Left            =   1320
      TabIndex        =   2
      Top             =   1080
      Width           =   1335
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   375
      Left            =   3000
      TabIndex        =   3
      Top             =   1080
      Width           =   1335
   End
   Begin VB.TextBox txtUID 
      Height          =   270
      Left            =   2160
      TabIndex        =   0
      Top             =   240
      Width           =   2535
   End
   Begin VB.TextBox txtPWD 
      Height          =   270
      IMEMode         =   3  'DISABLE
      Left            =   2160
      PasswordChar    =   "*"
      TabIndex        =   1
      Top             =   600
      Width           =   2535
   End
   Begin VB.Image Image1 
      Height          =   480
      Left            =   360
      Picture         =   "frmAskUser.frx":058A
      Top             =   240
      Width           =   480
   End
   Begin VB.Label Label2 
      Caption         =   "口令:"
      Height          =   255
      Left            =   1200
      TabIndex        =   5
      Top             =   600
      Width           =   975
   End
   Begin VB.Label Label1 
      Caption         =   "用户名:"
      Height          =   255
      Left            =   1200
      TabIndex        =   4
      Top             =   240
      Width           =   975
   End
End
Attribute VB_Name = "frmAskUser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit
'INI变量
Public g_Password As String
Public g_Database As String
Public g_DSN As String
Public g_UID As String
Public g_PWD As String
Public g_Server As String
Public g_Driver As String
Public g_DataSourceType As String
Public g_Check As Integer
'系统用户
Public gValidUser As Boolean            '是否为合法用户
Public gUserCount As Integer            '当前用户数


Private Sub cmdCancel_Click()
    g_Database = ""
    gValidUser = False
    gCurUser = ""
    Unload Me
'    End
End Sub


Private Sub cmdOK_Click()
Dim temUID As String
Dim temPWD As String
Dim sErr As String

    temUID = txtUID.Text
    temPWD = txtPWD.Text
    If CheckValidUser(temUID, temPWD, sErr) Then
        gCurUser = temUID
        gCurUserPWD = temPWD
        gValidUser = True
        Unload Me
    Else
        MsgBox sErr, vbOKOnly, Me.Caption
        If txtUID.Enabled Then txtUID.SetFocus
    End If
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

    '----------------------------------------------------------------
    CheckValidUser = False
    vErr = ""
    gRInput = False
    gRQuery = False
    gRAdmin = False
    gRExt = False
    '----------------------------------------------------------------
    strSQL = "SELECT * FROM SYS_Users 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
        DisPack temPWD
        If temPWD <> vPWD Then
            vErr = "用户名或口令错误!"
        Else
            If Not IsNull(rcUsers!Role) Then
                temRole = Trim(rcUsers!Role)
            End If
            aRole = Split(temRole, ",")
            For I = 0 To UBound(aRole)
                If aRole(I) = USER_INPUT Then
                    gRInput = True
                    CheckValidUser = True
                End If
                If aRole(I) = USER_QUERY Then
                    gRQuery = True
                    CheckValidUser = True
                End If
                If aRole(I) = USER_ADMIN Then
                    gRAdmin = True
                    CheckValidUser = True
                End If
                If aRole(I) = USER_EXT Then
                    gRExt = True
                    CheckValidUser = True
                End If
            Next I
            If CheckValidUser Then Exit Do
            vErr = "没有足够的权限!"
        End If
        rcUsers.MoveNext
    Loop
    Exit Function
    
err_OpenUsers:
    ShowError "无法打开系统用户表", ERR_SHOW_OK
    Exit Function
End Function