frmadduser.frm

《VB6数据库开发指南》所有的例程的源码

VERSION 5.00
Begin VB.Form frmAddUser 
   Caption         =   "Add User"
   ClientHeight    =   2505
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4320
   LinkTopic       =   "Form1"
   ScaleHeight     =   2505
   ScaleWidth      =   4320
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdAddUser 
      Caption         =   "&Add User"
      Height          =   435
      Left            =   2880
      TabIndex        =   3
      Top             =   960
      Width           =   1335
   End
   Begin VB.CommandButton cmdClose 
      Cancel          =   -1  'True
      Caption         =   "&Close"
      Default         =   -1  'True
      Height          =   435
      Left            =   2880
      TabIndex        =   2
      Top             =   360
      Width           =   1335
   End
   Begin VB.ListBox lstUsers 
      Enabled         =   0   'False
      Height          =   2010
      Left            =   120
      TabIndex        =   1
      Top             =   360
      Width           =   2595
   End
   Begin VB.Label lblUsers 
      Caption         =   "&Users"
      Height          =   255
      Left            =   180
      TabIndex        =   0
      Top             =   120
      Width           =   1935
   End
End
Attribute VB_Name = "frmAddUser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit


Private Sub Form_Load()

' if there is an error then goto the code section labeled by ERR_Form_Load
On Error GoTo ERR_Form_Load:

    Dim sUserName As String
    Dim sPassword As String
    
    ' assign default user name and password
    sUserName = "Admin"
    sPassword = ""
    
    With DBEngine
        
        ' set system database path and name
        .SystemDB = GetWorkgroupDatabase

        ' set default user name and password
        .DefaultUser = sUserName
        .DefaultPassword = sPassword
    
    End With
    
    ' popluate the users list box with the available uesrs
    FillUserList
    
Exit Sub

ERR_Form_Load:

    ' display error for the user
    With Err
        MsgBox "ERROR #" & .Number & ": " & .Description, vbExclamation, _
               "ERROR"
    End With

    ' end the application
    cmdClose_Click
    
End Sub

Private Sub cmdAddUser_Click()

' if there is an error then goto code labeled by ERR_cmdAddUser_Click
On Error GoTo ERR_cmdAddUser_Click:

    ' local variables used to store passwords
    Dim sNewUserName As String
    Dim sNewPassword As String
    Dim sConPassword As String
    
    ' local variables used for the new user
    Dim sPID As String
    Dim oNewUser As User
    
    ' constant declarations for application defined error messages
    Const ERR_NO_USER_NAME = 32000
    Const ERR_PASSWORD_TOO_LONG = 32001
    Const ERR_PASSWORDS_NOT_EQUAL = 32002
    
    ' enter a new user name
    sNewUserName = InputBox("Please enter a new user name.", "ADD USER")
                            
    ' trim excess white spaces from the user name
    sNewUserName = Trim$(sNewUserName)
    
    ' if no user name is entered, notify the user and abandon task
    If (sNewUserName = "") Then Error ERR_NO_USER_NAME
    
    ' ask for new password
    sNewPassword = InputBox("Please enter the new password for user '" _
                            & sNewUserName & "'.", "ADD USER")
                            
    ' if the password is too long, notify the user and end the task
    If (Len(sNewPassword) > 14) Then Error ERR_PASSWORD_TOO_LONG
    
    ' confirm new password
    sConPassword = InputBox("Please confirm new password for user '" _
                            & sNewUserName & "'.", "ADD USER")
                            
    ' if new password is not equivalent to the confirmed password,
    ' notify the user and end the task
    If (sNewPassword <> sConPassword) Then Error ERR_PASSWORDS_NOT_EQUAL
    
    'get a PID for the new user
    sPID = GetNewPID(sNewUserName)
    
    With DBEngine
    
        ' create a new user object from user name, pid, and password
        Set oNewUser = .Workspaces(0).CreateUser(sNewUserName, _
                                                 sPID, _
                                                 sNewPassword)
                                                 
        ' append the new users to the workspace
        .Workspaces(0).Users.Append oNewUser
    
    End With
        
    ' repopulate list box with new users
    FillUserList
    
    ' notify the user of success
    MsgBox "User '" & sNewUserName & "' added successfully.", _
            vbInformation, "ADD USER"
                                    
Exit Sub

ERR_cmdAddUser_Click:

    ' variable used for error message
    Dim sMessage As String
    
    With Err
    
        ' create an error message for given error code
        Select Case .Number
            
            Case ERR_NO_USER_NAME:
                sMessage = "You did not enter a user name."
                
            Case ERR_PASSWORD_TOO_LONG:
                sMessage = "The password must be 14 characters or less"
                
            Case ERR_PASSWORDS_NOT_EQUAL:
                sMessage = "The confirmed password is not equivalent to " _
                         & "the new password."
                         
            ' unexpected error, create an error message from the error
            ' number and description
            Case Else:
                sMessage = "ERROR #" & .Number & ": " & .Description
        
        End Select
        
    End With
    
    ' display the error message for the user
    MsgBox sMessage, vbExclamation, "ERROR"
    
End Sub

Private Sub cmdClose_Click()
    
    ' end the application
    Unload Me
    
End Sub

Private Sub FillUserList()
    
    Dim oUser As User
    
    With lstUsers
        
        ' clear current list of users
        .Clear
        
        ' populate the user list boxes with all users
        For Each oUser In DBEngine.Workspaces(0).Users
            .AddItem oUser.Name
        Next
    
    End With
    
End Sub

Private Function GetNewPID(sUserName As String) As String

    Dim sPID As String
    
    ' create new PID
    sPID = sUserName
    
    If (Len(sPID) > 20) Then
        
        ' if the PID is greater than 20 characters, shorten it
        sPID = Left$(sPID, 20)
    
    Else
        
        ' if the PID is less than 4 characters, add some underscores
        While (Len(sPID) < 4)
            sPID = sPID & "_"
        Wend
    
    End If
    
    ' return newly created PID value
    GetNewPID = sPID
    
End Function