frmaddgroup.frm

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

VERSION 5.00
Begin VB.Form frmAddGroup 
   Caption         =   "Add Group"
   ClientHeight    =   2505
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4320
   LinkTopic       =   "Form1"
   ScaleHeight     =   2505
   ScaleWidth      =   4320
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdAddGroup 
      Caption         =   "&Add Group"
      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 lstGroups 
      Enabled         =   0   'False
      Height          =   2010
      Left            =   120
      TabIndex        =   1
      Top             =   360
      Width           =   2595
   End
   Begin VB.Label lblGroups 
      Caption         =   "&Groups"
      Height          =   255
      Left            =   180
      TabIndex        =   0
      Top             =   120
      Width           =   1935
   End
End
Attribute VB_Name = "frmAddGroup"
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 group list box with the available groups
    FillGroupList
    
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 cmdAddGroup_Click()

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

    ' local variables used to store new group name
    Dim sNewGroupName As String
    
    ' local variables used for the new group
    Dim sPID As String
    Dim oNewGroup As Group
    
    ' constant declaration for application defined error message
    Const ERR_NO_GROUP_NAME = 32000
    
    ' enter a new group name
    sNewGroupName = InputBox("Please enter a new group name.", "ADD GROUP")
                            
    ' trim excess white spaces from the group name
    sNewGroupName = Trim$(sNewGroupName)
    
    ' if no group name is entered, notify the user and abandon task
    If (sNewGroupName = "") Then Error ERR_NO_GROUP_NAME
    
    'get a PID for the new group
    sPID = GetNewPID(sNewGroupName)
    
    With DBEngine
    
        ' create a new group object from group name, PID, and password
        Set oNewGroup = .Workspaces(0).CreateGroup(sNewGroupName, sPID)
                                                 
        ' append the new groups to the workspace
        .Workspaces(0).Groups.Append oNewGroup
    
    End With
        
    ' repopulate list box with new groups
    FillGroupList
    
    ' notify the user of success
    MsgBox "Group '" & sNewGroupName & "' added successfully.", _
            vbInformation, "ADD GROUP"
                                    
Exit Sub

ERR_cmdAddGroup_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_GROUP_NAME:
                sMessage = "You did not enter a group name."
                
            ' 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"
    Stop
    Resume
End Sub

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

Private Sub FillGroupList()
    
    Dim oGroup As Group
    
    With lstGroups
        
        ' clear current list of groups
        .Clear
        
        ' populate the group list boxes with all groups
        For Each oGroup In DBEngine.Workspaces(0).Groups
            .AddItem oGroup.Name
        Next
    
    End With
    
End Sub

Private Function GetNewPID(sGroupName As String) As String

    Dim sPID As String
    
    ' create new PID
    sPID = sGroupName
    
    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