frmpasswords.frm

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

VERSION 5.00
Begin VB.Form frmPasswords 
   Caption         =   "Passwords"
   ClientHeight    =   2505
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4545
   LinkTopic       =   "Form1"
   ScaleHeight     =   2505
   ScaleWidth      =   4545
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdDeletePassword 
      Caption         =   "&Delete Password"
      Height          =   435
      Left            =   2880
      TabIndex        =   4
      Top             =   1440
      Width           =   1575
   End
   Begin VB.CommandButton cmdChangePassword 
      Caption         =   "C&hange Password"
      Height          =   435
      Left            =   2880
      TabIndex        =   3
      Top             =   960
      Width           =   1575
   End
   Begin VB.CommandButton cmdClose 
      Cancel          =   -1  'True
      Caption         =   "&Close"
      Default         =   -1  'True
      Height          =   435
      Left            =   2880
      TabIndex        =   2
      Top             =   360
      Width           =   1575
   End
   Begin VB.ListBox lstUsers 
      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 = "frmPasswords"
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
    
    ' if there are no valid users, inform the user and exit the application
    If (lstUsers.ListCount < 1) Then
        
        MsgBox "There are no users!", vbExclamation, "USERS"
        cmdClose_Click
        
    Else
        
        ' initialize the list boxes to point to the first item in users list
        lstUsers.ListIndex = 0
    
    End If
    
    
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 cmdChangePassword_Click()

    ' local variables used to store passwords
    Dim sOldPassword As String
    Dim sNewPassword As String
    Dim sConPassword As String
    
    ' ask for old password
    sOldPassword = InputBox("Please enter the old password for user '" _
                            & lstUsers.Text & "'.", "CHANGE PASSWORD")
                            
    ' ask for new password
    sNewPassword = InputBox("Please enter the new password for user '" _
                            & lstUsers.Text & "'.", "CHANGE PASSWORD")
                            
    ' confirm new password
    sConPassword = InputBox("Please confirm new password for user '" _
                            & lstUsers.Text & "'.", "CHANGE PASSWORD")
                            
    ' if new password is not equivalent to the confirmed password,
    ' notify the user and end the task, otherwise, change the password
    If (sNewPassword <> sConPassword) Then
    
        MsgBox "New password does not match confirmed password.", _
                vbExclamation, "ERROR"
                
    Else
    
        ChangePassword sOldPassword, sNewPassword
        
    End If
                            
End Sub

Private Sub cmdDeletePassword_Click()

    ' local variable used to store old password
    Dim sOldPassword As String
    
    ' ask for old password
    sOldPassword = InputBox("Please enter the old password for user '" _
                            & lstUsers.Text & "'.", "DELETE PASSWORD")
                            
    ' change the password
    ChangePassword sOldPassword, ""
                            
End Sub

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

Private Sub FillUserList()
    
    Dim oUser As User
    
    ' populate the user list boxes with all users except CREATOR and ENGINE
    ' (these shouldn't be changed)
    For Each oUser In DBEngine.Workspaces(0).Users
        
        With oUser
            
            If (UCase$(.Name) <> "CREATOR") _
            And (UCase$(.Name) <> "ENGINE") Then
            
                lstUsers.AddItem .Name
            
            End If
        
        End With
    
    Next
    
End Sub

Private Sub ChangePassword(sOldPassword As String, _
                           sNewPassword As String)
                           
' if there is an error then goto the code labeled by ERR_ChangePassword
On Error GoTo ERR_ChangePassword:

    ' constant used to define application defined error
    Const ERR_PASSWORD_TOO_LONG = 32000

    ' if the new password is too long, raise application defined error
    If (Len(sNewPassword) > 14) Then Error ERR_PASSWORD_TOO_LONG
    
    ' change password, given the old and new passwords
    DBEngine.Workspaces(0).Users(lstUsers.Text).NewPassword sOldPassword, _
                                                            sNewPassword

    ' if we got this far, we must be successful, notify the user
    MsgBox "Password successfully changed for user '" _
           & lstUsers.Text & "'", vbInformation, "SUCCESS"
           
Exit Sub

ERR_ChangePassword:

    ' local variable used to hold error message
    Dim sMessage As String

    With Err
        
        Select Case .Number
        
            ' application defined error, password too long
            Case ERR_PASSWORD_TOO_LONG:
                sMessage = "The password must be 14 characters or less."
                
            ' unexpected error, create error message with number and
            ' description
            Case Else:
                sMessage = "ERROR #" & .Number & ": " & .Description
            
        End Select
    
    End With
    
    
    ' display error for the user
    MsgBox sMessage, vbExclamation, "ERROR"

End Sub