MI HAYATUL ISLAM: June 2012

Breaking News

Tuesday, June 26, 2012

Ex21: VBA - Reset Seed / Autonumber using ADOX

Reset the Seed of the AutoNumber using ADOX in VBA

Function ResetSeed(strTable As String) As String
    'Purpose:   Reset the Seed of the AutoNumber, using ADOX.
    Dim strAutoNum As String    'Name of the autonumber column.
    Dim lngSeed As Long         'Current value of the Seed.
    Dim lngNext As Long         'Next unused value.
    Dim strSql As String
    Dim strResult As String
    
    lngSeed = GetSeedADOX(strTable, strAutoNum)
    If strAutoNum = vbNullString Then
        strResult = "AutoNumber not found."
    Else
        lngNext = Nz(DMax(strAutoNum, strTable), 0) + 1
        If lngSeed = lngNext Then
            strResult = strAutoNum & " already correctly set to " & lngSeed & "."
        Else
            Debug.Print lngNext, lngSeed
            strSql = "ALTER TABLE [" & strTable & "] ALTER COLUMN [" & strAutoNum & "] COUNTER(" & lngNext & ", 1);"
            Debug.Print strSql
            CurrentProject.Connection.Execute strSql
            strResult = strAutoNum & " reset from " & lngSeed & " to " & lngNext
        End If
    End If
    ResetSeed = strResult
End Function

Ex20: VBA - Read Seed / Autonumber using ADOX

Read the Seed of the AutoNumber of a table using ADOX in VBA

Function GetSeedADOX(strTable As String, Optional ByRef strCol As String) As Long
    'Purpose:   Read the Seed of the AutoNumber of a table.
    'Arguments: strTable the table to examine.
    '           strCol = the name of the field. If omited, the code finds it.
    'Return:    The seed value.
    Dim cat As New ADOX.Catalog 'Root object of ADOX.
    Dim tbl As ADOX.Table       'Each Table in Tables.
    Dim col As ADOX.Column      'Each Column in the Table.
    
    'Point the catalog to the current project's connection.
    Set cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables(strTable)
    
    'Loop through the columns to find the AutoNumber.
    For Each col In tbl.Columns
        If col.Properties("Autoincrement") Then
            strCol = col.Name
            GetSeedADOX = col.Properties("Seed")
            Exit For    'There can be only one AutoNum.
        End If
    Next
    
    'Clean up
    Set col = Nothing
    Set tbl = Nothing
    Set cat = Nothing
End Function

Ex19: VBA - Delete all record using ADOX

Delete all records from the table, and reset the AutoNumber using ADOX in VBA

Function DeleteAllAndResetAutoNum(strTable As String) As Boolean
    'Purpose:   Delete all records from the table, and reset the AutoNumber using ADOX.
    '           Also illustrates how to find the AutoNumber field.
    'Argument:  Name of the table to reset.
    'Return:    True if sucessful.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim col As ADOX.Column
    Dim strSql As String
    
    'Delete all records.
    strSql = "DELETE FROM [" & strTable & "];"
    CurrentProject.Connection.Execute strSql
    
    'Find and reset the AutoNum field.
    cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables(strTable)
    For Each col In tbl.Columns
        If col.Properties("Autoincrement") Then
            col.Properties("Seed") = 1
            DeleteAllAndResetAutoNum = True
        End If
    Next
End Function

Ex18: Create a database using ADOX

Function CreateDatabaseAdox()
    'Purpose:   Create a database using ADOX.
    Dim cat As New ADOX.Catalog
    Dim strFile As String

    strFile = "C:\SampleADOX.mdb"
    cat.Create "Provider='Microsoft.Jet.OLEDB.4.0';" & _
        "Data Source='" & strFile & "'"
    Set cat = Nothing
    Debug.Print strFile & " created."
End Function

Ex17: VBA - Delete a parameter/action query using ADOX

Function DeleteProcedureAdox()
    'Purpose:   Delete a parameter/action query using ADOX.
    Dim cat As New ADOX.Catalog
    Dim cmd As ADODB.Command
    Dim lngCount As Long
    
    'Initialize.
    cat.ActiveConnection = CurrentProject.Connection
    cat.Procedures.Delete "qryAdoxDeleteBooking"
    Set cat = Nothing
End Function

Ex16: VBA - Execute a parameter query using ADOX

Function ExecuteProcedureAdox()
    'Purpose:   Execute a parameter query using ADOX.
    Dim cat As New ADOX.Catalog
    Dim cmd As ADODB.Command
    Dim lngCount As Long
    
    'Initialize.
    cat.ActiveConnection = CurrentProject.Connection
    Set cmd = cat.Procedures("qryAdoxDeleteBooking").Command
    
    'Supply the parameters
    cmd.Parameters("StartDate") = #1/1/2004#
    cmd.Parameters("EndDate") = #12/31/2004#
    
    'Execute the procedure
    cmd.Execute lngCount
    Debug.Print lngCount & " record(s) deleted."
    
    'Alternative: specify the parameters in a variant array.
    'cmd.Execute , Array(#1/1/2004#, #12/31/2004#)
    
    'Clean up.
    Set cmd = Nothing
    Set cat = Nothing
End Function

Ex14: VBA - Create a parameter / action query using ADOX

Function CreateProcedureAdox()
    'Purpose:   Create a parameter query or action query using ADOX.
    Dim cat As New ADOX.Catalog
    Dim cmd As New ADODB.Command
    Dim strSql As String
    
    'Initialize.
    cat.ActiveConnection = CurrentProject.Connection
    
    ''Assign the SQL statement to the CommandText property.
    strSql = "PARAMETERS StartDate DateTime, EndDate DateTime; " & _
        "DELETE FROM tblAdoxBooking " & _
        "WHERE BookingDate Between StartDate And EndDate;"
    cmd.CommandText = strSql
    
    'Append the Command to the Procedures collection of the catalog.
    cat.Procedures.Append "qryAdoxDeleteBooking", cmd
    
    'Clean up.
    Set cmd = Nothing
    Set cat = Nothing
    Debug.Print "Procedure created."
End Function

Ex15: VBA - List the parameter/action queries using ADOX

Function ShowProx()
    'Purpose:   List the parameter/action queries using ADOX.
    Dim cat As New ADOX.Catalog
    Dim proc As ADOX.Procedure
    Dim vw As ADOX.View
    
    cat.ActiveConnection = CurrentProject.Connection
    
    Debug.Print "Procedures: " & cat.Procedures.Count
    For Each proc In cat.Procedures
        Debug.Print proc.Name
    Next
    Debug.Print cat.Procedures.Count & " procedure(s)"
    Debug.Print
    
    Debug.Print "Views " & cat.Views.Count
    For Each vw In cat.Views
        Debug.Print vw.Name
    Next
    
    Set cat = Nothing
End Function

Ex13: VBA - Create a query using ADOX

Function CreateViewAdox()
    'Purpose:   Create a query using ADOX.
    Dim cat As New ADOX.Catalog
    Dim cmd As New ADODB.Command
    Dim strSql As String
    
    'Initialize.
    cat.ActiveConnection = CurrentProject.Connection
    
    'Assign the SQL statement to Command object's CommandText property.
    strSql = "SELECT BookingID, BookingDate FROM tblDaoBooking;"
    cmd.CommandText = strSql
    
    'Append the Command to the Views collectiion of the catalog.
    cat.Views.Append "qryAdoxBooking", cmd
    
    'Clean up.
    Set cmd = Nothing
    Set cat = Nothing
    Debug.Print "View created."
End Function

Ex12: VBA - Delete relationships using ADOX

Function DeleteKeyAdox()
    'Purpose:   Delete relationships using ADOX.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    
    Set cat.ActiveConnection = CurrentProject.Connection
    cat.Tables("tblAdoxBooking").Keys.Delete "tblAdoxContractortblAdoxBooking"
    
    Set cat = Nothing
    Debug.Print "Key deleted."
End Function

Ex11: VBA - List relationships using ADOX

Function ShowKeyAdox(strTableName As String)
    'Purpose:   List relationships using ADOX.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim ky As ADOX.Key
    Dim strRIName As String
    
    Set cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables(strTableName)
    
    For Each ky In tbl.Keys
        With ky
            Select Case .DeleteRule
            Case adRINone
                strRIName = "No delete rule"
            Case adRICascade
                strRIName = "Cascade delete"
            Case adRISetNull
                strRIName = "Cascade to null"
            Case adRISetDefault
                strRIName = "Cascade to default"
            Case Else
                strRIName = "DeleteRule of " & .DeleteRule & " unknown."
            End Select
            Debug.Print "Key: " & .Name & ", to table: " & .RelatedTable & ", with: " & strRIName
        End With
    Next

    Set ky = Nothing
    Set tbl = Nothing
    Set cat = Nothing
End Function

Ex10: VBA - Create relationships using ADOX

Show how to create relationships using ADOX in VBA

Function CreateKeyAdox()
    'Purpose:   Show how to create relationships using ADOX.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim ky As New ADOX.Key
    
    Set cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables("tblAdoxBooking")
    
    'Create as foreign key to tblAdoxContractor.ContractorID
    With ky
        .Type = adKeyForeign
        .Name = "tblAdoxContractortblAdoxBooking"
        .RelatedTable = "tblAdoxContractor"
        .Columns.Append "ContractorID"      'Just one field.
        .Columns("ContractorID").RelatedColumn = "ContractorID"
        .DeleteRule = adRISetNull   'Cascade to Null on delete.
    End With
    tbl.Keys.Append ky
    
    Set ky = Nothing
    Set tbl = Nothing
    Set cat = Nothing
    Debug.Print "Key created."
End Function

Ex9: VBA - Delete indexes using ADOX

Show how to delete indexes using ADOX in VBA

Function DeleteIndexAdox()
    'Purpose:   Show how to delete indexes using ADOX.
    Dim cat As New ADOX.Catalog
    cat.ActiveConnection = CurrentProject.Connection
    cat.Tables("tblAdoxContractor").Indexes.Delete "Inactive"
    Set cat = Nothing
End Function

Ex8: VBA - Create indexes using ADOX

Show how to create indexes using ADOX in VBA

Function CreateIndexesAdox()
    'Purpose:   Show how to create indexes using ADOX.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim ind As ADOX.Index
    
    'Initialize
    Set cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables("tblAdoxContractor")

    'Create a primary key index
    Set ind = New ADOX.Index
    ind.Name = "PrimaryKey"
    ind.PrimaryKey = True
    ind.Columns.Append "ContractorID"
    tbl.Indexes.Append ind
    Set ind = Nothing
    
    'Create an index on one column.
    Set ind = New ADOX.Index
    ind.Name = "Inactive"
    ind.Columns.Append "Inactive"
    tbl.Indexes.Append ind
    Set ind = Nothing
    
    'Multi-field index.
    Set ind = New ADOX.Index
    ind.Name = "FullName"
    With ind.Columns
        .Append "Surname"
        .Append "FirstName"
    End With
    tbl.Indexes.Append ind
    
    'Clean up
    Set ind = Nothing
    Set tbl = Nothing
    Set cat = Nothing
    Debug.Print "tblAdoxContractor indexes created."
End Function

Ex7: VBA - Delete a table using ADOX

Function DeleteTableAdox()
    'Purpose:   Delete a table using ADOX.
    Dim cat As New ADOX.Catalog
    
    cat.ActiveConnection = CurrentProject.Connection
    cat.Tables.Delete "MyTable"
    Set cat = Nothing
End Function

Ex6: VBA - Modify field properties using ADOX

Show how to alter field properties using ADOX in VBA

Function ModifyFieldPropAdox()
    'Purpose:   Show how to alter field properties, using ADOX.
    'Note:      You cannot alter the DefinedSize of the field like this.
    Dim cat As New ADOX.Catalog
    Dim col As ADOX.Column
    Dim prp As ADOX.Property

    cat.ActiveConnection = CurrentProject.Connection
    Set col = cat.Tables("MyTable").Columns("MyField")
    'col.ParentCatalog = cat
    Set prp = col.Properties("Nullable")
    'Read the property
    Debug.Print prp.Name, prp.Value, (prp.Type = adBoolean)
    'Change the property
    prp.Value = Not prp.Value
    
    'Clean up
    Set prp = Nothing
    Set col = Nothing
    Set cat = Nothing
End Function

Ex5: VBA - Modify table using ADOX

Show how to add fields to a table, and delete them using ADOX in VBA

Function ModifyTableAdox()
    'Purpose:   Show how to add fields to a table, and delete them using ADOX.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim col As New ADOX.Column
    
    'Initialize
    cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables("tblAdoxContractor")
    
    'Add a new column
    With col
        .Name = "MyDecimal"
        .Type = adNumeric   'Decimal type.
        .Precision = 28     '28 digits.
        .NumericScale = 8   '8 decimal places.
    End With
    tbl.Columns.Append col
    Set col = Nothing
    Debug.Print "Column added."
    
    'Delete a column.
    tbl.Columns.Delete "MyDecimal"
    Debug.Print "Column deleted."
    
    'Clean up
    Set col = Nothing
    Set tbl = Nothing
    Set cat = Nothing
End Function

Ex4: VBA - Create a table using ADOX

Create a table with various field types using ADOX in VBA

Function CreateTableAdox()
    'Purpose:   Create a table with various field types, using ADOX.
    Dim cat As New ADOX.Catalog
    Dim tbl As ADOX.Table
    
    Set cat.ActiveConnection = CurrentProject.Connection
    'Initialize the Contractor table.
    Set tbl = New ADOX.Table
    tbl.Name = "tblAdoxContractor"
    
    'Append the columns.
    With tbl.Columns
        .Append "ContractorID", adInteger   'Number (Long Integer)
        .Append "Surname", adVarWChar, 30   'Text (30 max)
        .Append "FirstName", adVarWChar, 20 'Text (20 max)
        .Append "Inactive", adBoolean       'Yes/No
        .Append "HourlyFee", adCurrency     'Currency
        .Append "PenaltyRate", adDouble     'Number (Double)
        .Append "BirthDate", adDate         'Date/Time
        .Append "Notes", adLongVarWChar     'Memo
        .Append "Web", adLongVarWChar       'Memo (for hyperlink)
        
        'Set the field properties.
        'AutoNumber
        With !ContractorID
            Set .ParentCatalog = cat
            
            .Properties("Autoincrement") = True     'AutoNumber.
            .Properties("Description") = "Automatically " & _
                "generated unique identifier for this record."
        End With
        
        'Required field.
        With !Surname
            Set .ParentCatalog = cat
            .Properties("Nullable") = False         'Required.
            .Properties("Jet OLEDB:Allow Zero Length") = False
        End With
        
        'Set a validation rule.
        With !BirthDate
            Set .ParentCatalog = cat
            .Properties("Jet OLEDB:Column Validation Rule") = _
                "Is Null Or <=Date()"
            .Properties("Jet OLEDB:Column Validation Text") = _
                "Birth date cannot be future."
        End With
        
        'Hyperlink field.
        With !Web
            Set .ParentCatalog = cat
            .Properties("Jet OLEDB:Hyperlink") = True 'Hyperlink.
        End With
    End With
    
    'Save the new table by appending to catalog.
    cat.Tables.Append tbl
    Debug.Print "tblAdoxContractor created."
    Set tbl = Nothing
    
    'Initialize the Booking table
    Set tbl = New ADOX.Table
    tbl.Name = "tblAdoxBooking"
    
    'Append the columns.
    With tbl.Columns
        .Append "BookingID", adInteger
        .Append "BookingDate", adDate
        .Append "ContractorID", adInteger
        .Append "BookingFee", adCurrency
        .Append "BookingNote", adWChar, 255
        
        'Set the field properties.
        With !BookingID                             'AutoNumber.
            .ParentCatalog = cat
            .Properties("Autoincrement") = True
        End With
        With !BookingNote                           'Required.
            .ParentCatalog = cat
            .Properties("Nullable") = False
            .Properties("Jet OLEDB:Allow Zero Length") = False
        End With
    End With
    
    'Save the new table by appending to catalog.
    cat.Tables.Append tbl
    Debug.Print "tblAdoxBooking created."
    
    'Clean up
    Set tbl = Nothing
    Set cat = Nothing
End Function

Ex3: VBA - Show the columns in a table using ADOX

Show the columns in a table, and optionally their properties

Function ShowPropsADOX(strTable As String, Optional bShowPropertiesToo As Boolean)
    'Purpose:   Show the columns in a table, and optionally their properties, using ADOX.
    Dim cat As New ADOX.Catalog 'Root object of ADOX.
    Dim tbl As ADOX.Table       'Each Table in Tables.
    Dim col As ADOX.Column      'Each Column in the Table.
    Dim prp As ADOX.Property
    
    'Point the catalog to the current project's connection.
    Set cat.ActiveConnection = CurrentProject.Connection
    Set tbl = cat.Tables(strTable)
    
    For Each col In tbl.Columns
        Debug.Print col.Name        ', col.Properties("Fixed length"), col.Type
        If bShowPropertiesToo Then
            For Each prp In col.Properties
                Debug.Print , prp.Name, prp.Type, prp.Value
            Next
            Debug.Print "--------------------------------"
            'Stop
        End If
    Next
    
    'Clean up
    Set prp = Nothing
    Set col = Nothing
    Set tbl = Nothing
    Set cat = Nothing
End Function

Ex2: VBA - List the tables using ADOX

Function ShowAllTables(Optional bShowFieldsToo As Boolean)
    'Purpose:   List the tables (and optionally their fields) using ADOX.
    Dim cat As New ADOX.Catalog 'Root object of ADOX.
    Dim tbl As ADOX.Table       'Each Table in Tables.
    Dim col As ADOX.Column      'Each Column in the Table.
    
    'Point the catalog to the current project's connection.
    Set cat.ActiveConnection = CurrentProject.Connection
    
    'Loop through the tables.
    For Each tbl In cat.Tables
        Debug.Print tbl.Name, tbl.Type
        If bShowFieldsToo Then
        'Loop through the columns of the table.
        For Each col In tbl.Columns
            Debug.Print , col.Name, col.Type
        Next
        Debug.Print "--------------------------------"
        'Stop
        End If
    Next
    
    'Clean up
    Set col = Nothing
    Set tbl = Nothing
    Set cat = Nothing
End Function

Ex1: VBA - Set the Seed of an AutoNumber using ADOX

Function SetSeed(strTable As String, strAutoNum As String, lngID As Long) As Boolean
    'Purpose:   Set the Seed of an AutoNumber using ADOX.
    Dim cat As New ADOX.Catalog
    
    Set cat.ActiveConnection = CurrentProject.Connection
    cat.Tables(strTable).Columns(strAutoNum).Properties("Seed") = lngID
    Set cat = Nothing
    SetSeed = True
End Function

ADOX Programming Code Examples in VBA

This page is a reference for developers, demonstrating how to use the ADOX library to programmatically create, delete, modify, and list the objects in Access - the tables, fields, indexes, and relations, queries, and databases - and read or set their properties.

ADOX is an extension to the ADO library, exposing the catalog of database objects. To use this library, open the code window, choose References on the Tools menu, and check the box beside:
Microsoft ADO Ext x.x for DDL and Security

In general, the DAO library is better than ADOX. DAO is purpose-designed for Access, and exposes properties the other libraries don't. But there are some things DAO cannot do, such as setting the Seed of an AutoNumber field. The ADOX library is less stable, and more subject to version problems, so if you strike problems with the code in this page, an MDAC update might address the issue for you.

See the field type reference for a comparison of the field types in ADOX compared to the Access interface and other libraries.

There is no explanation of the code beyond in-line comments, and no error handling in most examples.

Index of Functions	Description
SetSeed()	Set the Seed of an AutoNumber
ShowAllTables()	List the tables (and optionally their fields)
ShowPropsADOX()	Show the columns in a table, and optionally their properties
CreateTableAdox()	Create a table with various field types
ModifyTableAdox()	Show how to add fields to a table, and delete them
ModifyFieldPropAdox()	Show how to alter field properties
DeleteTableAdox()	Delete a table
CreateIndexesAdox()	Show how to create indexes
DeleteIndexAdox()	Show how to delete indexes
CreateKeyAdox()	Show how to create relationships
ShowKeyAdox()	List relationships
DeleteKeyAdox()	Delete relationships
CreateViewAdox()	Create a query
CreateProcedureAdox()	Create a parameter query or action query
ShowProx()	List the parameter/action queries
ExecuteProcedureAdox()	Execute a parameter query
DeleteProcedureAdox()	Delete a parameter/action query
CreateDatabaseAdox()	Create a database
DeleteAllAndResetAutoNum()	Delete all records from the table, and reset the AutoNumber
GetSeedADOX()	Read the Seed of the AutoNumber of a table
ResetSeed()	Reset the Seed of the AutoNumber.

Monday, June 25, 2012

Ex8: VBA - Distinct users Connected to DB using ADO

Count the number of distinct users connected to the database using ADO in VBA

Function UserCount() As Long
    Dim cnLocal As ADODB.Connection             'Current project connection.
    Dim cnBackEnd As New ADODB.Connection       'Connection to back end database.
    Dim rsBEUserRoster As New ADODB.Recordset   'JET User Roster for back end database.
    Dim rsTarget As New ADODB.Recordset         'Temp table to record users and de-dupe.
    Dim strPath As String                       'Full path to back end.
    Dim strSql As String                        'SQL string.
    Dim lngKt As Long                           'Loop controller.
    Dim dtEnteredOn As Date                     'Current date and time.
    
    'Set this to the full path of your back end database.
    strPath = "C:\Data\Northwind2003.mdb"
    
    'Open the JET User Roster for the back end.
    cnBackEnd.Provider = "Microsoft.Jet.OLEDB.4.0"
    cnBackEnd.Open "Data Source=" & strPath
    Set rsBEUserRoster = cnBackEnd.OpenSchema(adSchemaProviderSpecific, , _
        "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
    
    'Clear temp table, and copy the user roster in.
    dtEnteredOn = Now()
    Set cnLocal = CurrentProject.Connection
    cnLocal.Execute "DELETE FROM tzJetUserRoster;"
    rsTarget.Open "tzJetUserRoster", cnLocal, adOpenDynamic, adLockOptimistic
    Do While Not rsBEUserRoster.EOF
        rsTarget.AddNew
            For lngKt = 0 To 3
                rsTarget(lngKt) = rsBEUserRoster(lngKt)
                rsTarget!EnteredOn = dtEnteredOn
            Next
        rsTarget.Update
        rsBEUserRoster.MoveNext
    Loop
    rsTarget.Close
    rsBEUserRoster.Close
    cnBackEnd.Close
    
    'Get the count of the number of distinct users who are connected.
    strSql = "SELECT DISTINCT Computer_Name FROM tzJetUserRoster WHERE Connected = True;"
    Set rsTarget = New ADODB.Recordset
    rsTarget.Open strSql, cnLocal, adOpenKeyset
    If Not (rsTarget.BOF And rsTarget.EOF) Then
        rsTarget.MoveLast
        UserCount = rsTarget.RecordCount
    End If
    rsTarget.Close
    
    'Dereference objects
    Set rsTarget = Nothing
    Set rsBEUserRoster = Nothing
    Set cnLocal = Nothing
    Set cnBackEnd = Nothing
End Function

Ex7: VBA - Database Active users in ADO

List the users currently connected to the database using ADO in VBA

Function ShowUserRosterMultipleUsers()
    'Source: kb 198755.
    Dim cn As New ADODB.Connection
    'Dim cn2 As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim i, j As Long

    cn.Provider = "Microsoft.Jet.OLEDB.4.0"
    cn.Open "Data Source=C:\Data\Northwind2003.mdb"

    'cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=C:\Data\Northwind2003.mdb"

    ' The user roster is exposed as a provider-specific schema rowset
    ' in the Jet 4 OLE DB provider.  You have to use a GUID to
    ' reference the schema, as provider-specific schemas are not
    ' listed in ADO's type library for schema rowsets

    Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")

    'Output the list of all users in the current database.

    Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, "", rs.Fields(2).Name, rs.Fields(3).Name

    While Not rs.EOF
        Debug.Print rs.Fields(0), rs.Fields(1), rs.Fields(2), rs.Fields(3)
        rs.MoveNext
    Wend
End Function

Ex6: VBA - BNOT Operator in ADO

Illustrate BNOT (binary NOT) operator (ADO only.) in VBA

Function TestBnot()
    'Purpose:   Illustrate BNOT (binary NOT) operator (ADO only.)
    Dim cn As ADODB.Connection
    Dim strSql As String
    Dim lngKt As Long
    
    Set cn = CurrentProject.Connection
    strSql = "UPDATE MyTable SET MyIntFlip = BNOT MyInt WHERE MyIntFlip Is Not Null;"
    
    cn.Execute strSql, lngKt
    
    Set cn = Nothing
    TestBnot = lngKt
End Function

Ex5: VBA - BAND Operator in ADO

Illustrate the BAND operator with literals. (ADO only.) in VBA

Function ShowBand()
    Dim rs As New ADODB.Recordset
    rs.Open "SELECT (2 BAND 4) AS Result;", CurrentProject.Connection
    ShowBand = rs!Result
    rs.Close
    Set rs = Nothing
End Function

Function TestBand()
    'Purpose:   Illustrate BAND (binary AND) operator. (ADO only.)
    Dim rs As New ADODB.Recordset
    Dim strSql As String
    
    strSql = "SELECT MyBitField, (MyBitField BAND 2) <> 0 As MyResult FROM MyTable;"
    rs.Open strSql, CurrentProject.Connection
    
    Do While Not rs.EOF
        Debug.Print rs!MyBitfield, rs!MyResult
        rs.MoveNext
    Loop
    
    rs.Close
    Set rs = Nothing
End Function

Ex4: VBA - Modify a query using ADO

Modify a query using ADO in VBA

Function ModifyViewAdo()
    'Purpose:   Modify a query using ADO.
    Dim cn As ADODB.Connection
    Dim strSql As String
    
    strSql = "ALTER TABLE Query1 AS SELECT MyTable.* FROM MyTable;"
    Set cn = CurrentProject.Connection
    cn.Execute strSql
    
    Debug.Print "MyTableView modified"
    Set cn = Nothing
End Function

Ex3: VBA - Create a new query using ADO

Create a new query using ADO in VBA

Function CreateViewAdo()
    'Purpose:   Create a new query using ADO.
    Dim cn As ADODB.Connection
    Dim strSql As String
    
    strSql = "CREATE VIEW MyTableView AS SELECT MyTable.* FROM MyTable;"
    Set cn = CurrentProject.Connection
    cn.Execute strSql
    
    Debug.Print "MyTableView created"
    Set cn = Nothing
End Function

Ex2: VBA - Open a recordset using ADO

Open a recordset using ADO in VBA

Function AdoRecordsetExample()
    'Purpose:   Open a recordset using ADO.
    Dim rs As New ADODB.Recordset
    Dim strSql As String
    
    strSql = "SELECT MyField FROM MyTable;"
    rs.Open strSql, CurrentProject.Connection
    
    Do While Not rs.EOF
        Debug.Print rs!MyField
        rs.MoveNext
    Loop
    
    rs.Close
    Set rs = Nothing
End Function

Ex1: VBA - List the tables using ADO

List the tables using ADO in VBA

Function ShowSchema()
    'Purpose:   List the tables, using ADO.
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    
    Set cn = CurrentProject.Connection
    Set rs = cn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "TABLE"))
'    For i = 0 To rs.Fields.Count - 1
'        Debug.Print rs.Fields(i).Name
'    Next

    Do While Not rs.EOF
        Debug.Print rs.Fields("TABLE_NAME").Value
        rs.MoveNext
    Loop
    rs.Close
    
    Set rs = Nothing
    Set cn = Nothing
End Function

ADO programming examples in VBA

This page is a reference for developers, demonstrating how to use the ADO library to list and manipulate the objects in Access.

ADO (ActiveX Data Objects) is more generic than DAO (the one designed to handle the objects in Access), so supports features of databases other than Access. In the wider world beyond Access, ADO has largely been replaced by the quite different ADO.NET library.

In general, DAO is preferred over ADO, but there are some operations that work under ADO only. In general, these work in code only. They will not work if you try them in the Query window, since Access itself uses DAO. They also require JET 4 (Access 2000 or later.)

ADO provides only limited ways to manipulate the data structure (typically via DDL query statements), unless you also use the ADOX library which provides the extensions to get to the database catalog.

To use the ADO Library, choose References on the Tools menu in the code window, and check the box beside:
Microsoft ActiveX Data Objects 2.x Library

There is no explanation of the code beyond in-line comments, and no error handling in most examples.

Index of Functions	Description
ShowSchema()	List the tables
AdoRecordsetExample()	Open a recordset
CreateViewAdo()	Create a new query
ModifyViewAdo()	Modify a query
ShowBand()	Illustrate the BAND operator with literals. (ADO only.)
TestBnot()	Illustrate BNOT (binary NOT) operator (ADO only.)
TestBand()	Illustrate BAND (binary AND) operator. (ADO only.)
ShowUserRosterMultipleUsers()	List the users currently connected to the database.
UserCount()	Count the number of distinct users connected to the database.

Sunday, June 24, 2012

Ex24: VBA - GetName of AutoNumber using DAO

Get the name of the AutoNumber field, using DAO.

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function GetAutoNumDAO(strTable) As String
    'Purpose:   Get the name of the AutoNumber field, using DAO.
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    
    Set db = CurrentDb()
    Set tdf = db.TableDefs(strTable)
    
    For Each fld In tdf.Fields
        If (fld.Attributes And dbAutoIncrField) <> 0 Then
            GetAutoNumDAO = fld.Name
            Exit For
        End If
    Next
    
    Set fld = Nothing
    Set tdf = Nothing
    Set db = Nothing
End Function

Ex23: VBA - Execute SQL using DAO

Execute the SQL statement on the current database in a transaction using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Public Function ExecuteInTransaction(strSql As String, Optional strConfirmMessage As String) As Long
On Error GoTo Err_Handler
    'Purpose:   Execute the SQL statement on the current database in a transaction.
    'Return:    RecordsAffected if zero or above.
    'Arguments: strSql = the SQL statement to be executed.
    '           strConfirmMessage = the message to show the user for confirmation. Number will be added to front.
    '           No confirmation if ZLS.
    '           -1 on error.
    '           -2 on user-cancel.
    Dim ws As DAO.Workspace
    Dim db As DAO.Database
    Dim bInTrans As Boolean
    Dim bCancel As Boolean
    Dim strMsg As String
    Dim lngReturn As Long
    Const lngcUserCancel = -2&
    
    Set ws = DBEngine(0)
    ws.BeginTrans
    bInTrans = True
    Set db = ws(0)
    db.Execute strSql, dbFailOnError
    lngReturn = db.RecordsAffected
    If strConfirmMessage <> vbNullString Then
        If MsgBox(lngReturn & " " & Trim$(strConfirmMessage), vbOKCancel + vbQuestion, "Confirm") <> vbOK Then
            bCancel = True
            lngReturn = lngcUserCancel
        End If
    End If
    
    'Commmit or rollback.
    If bCancel Then
        ws.Rollback
    Else
        ws.CommitTrans
    End If
    bInTrans = False

Exit_Handler:
    ExecuteInTransaction = lngReturn
    On Error Resume Next
    Set db = Nothing
    If bInTrans Then
        ws.Rollback
    End If
    Set ws = Nothing
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "ExecuteInTransaction()"
    lngReturn = -1
    Resume Exit_Handler
End Function

Ex22: VBA - Show form properties using DAO

Loop through the controls on a form, showing names and properties using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function ShowFormProperties(strFormName As String)
On Error GoTo Err_Handler
    'Purpose:   Loop through the controls on a form, showing names and properties.
    'Usage:     Call ShowFormProperties("Form1")
    Dim frm As Form
    Dim ctl As Control
    Dim prp As Property
    Dim strOut As String
    
    DoCmd.OpenForm strFormName, acDesign, WindowMode:=acHidden
    Set frm = Forms(strFormName)
    
    For Each ctl In frm
        For Each prp In ctl.Properties
            strOut = strFormName & "." & ctl.Name & "." & prp.Name & ": "
            strOut = strOut & prp.Type & vbTab
            strOut = strOut & prp.Value
            Debug.Print strOut
        Next
        If ctl.ControlType = acTextBox Then Stop
    Next
    
    Set frm = Nothing
    DoCmd.Close acForm, strFormName, acSaveNo

Exit_Handler:
    Exit Function

Err_Handler:
    Select Case Err.Number
    Case 2186:
        strOut = strOut & Err.Description
        Resume Next
    Case Else
        MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "ShowFormProperties()"
        Resume Exit_Handler
    End Select
End Function

Ex21: VBA - Open & Loop through records using DAO

How to open a recordset and loop through the records using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function DAORecordsetExample()
    'Purpose:   How to open a recordset and loop through the records.
    'Note:      Requires a table named MyTable, with a field named MyField.
    Dim rs As DAO.Recordset
    Dim strSql As String
    
    strSql = "SELECT MyField FROM MyTable;"
    Set rs = DBEngine(0)(0).OpenRecordset(strSql)
    
    Do While Not rs.EOF
        Debug.Print rs!MyField
        rs.MoveNext
    Loop
    
    rs.Close
    Set rs = Nothing
End Function

Ex20: VBA - Convert numeric results using DAO

Converts the numeric results of DAO fieldtype to text using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Public Function FieldTypeName(fld As DAO.Field)
    'Purpose: Converts the numeric results of DAO fieldtype to text.
    'Note:    fld.Type is Integer, but the constants are Long.
    Dim strReturn As String         'Name to return
    
    Select Case CLng(fld.Type)
        Case dbBoolean: strReturn = "Yes/No"            ' 1
        Case dbByte: strReturn = "Byte"                 ' 2
        Case dbInteger: strReturn = "Integer"           ' 3
        Case dbLong                                     ' 4
            If (fld.Attributes And dbAutoIncrField) = 0& Then
                strReturn = "Long Integer"
            Else
                strReturn = "AutoNumber"
            End If
        Case dbCurrency: strReturn = "Currency"         ' 5
        Case dbSingle: strReturn = "Single"             ' 6
        Case dbDouble: strReturn = "Double"             ' 7
        Case dbDate: strReturn = "Date/Time"            ' 8
        Case dbBinary: strReturn = "Binary"             ' 9 (no interface)
        Case dbText                                     '10
            If (fld.Attributes And dbFixedField) = 0& Then
                strReturn = "Text"
            Else
                strReturn = "Text (fixed width)"
            End If
        Case dbLongBinary: strReturn = "OLE Object"     '11
        Case dbMemo                                     '12
            If (fld.Attributes And dbHyperlinkField) = 0& Then
                strReturn = "Memo"
            Else
                strReturn = "Hyperlink"
            End If
        Case dbGUID: strReturn = "GUID"                 '15
        
        'Attached tables only: cannot create these in JET.
        Case dbBigInt: strReturn = "Big Integer"        '16
        Case dbVarBinary: strReturn = "VarBinary"       '17
        Case dbChar: strReturn = "Char"                 '18
        Case dbNumeric: strReturn = "Numeric"           '19
        Case dbDecimal: strReturn = "Decimal"           '20
        Case dbFloat: strReturn = "Float"               '21
        Case dbTime: strReturn = "Time"                 '22
        Case dbTimeStamp: strReturn = "Time Stamp"      '23
        
        'Constants for complex types don't work prior to Access 2007.
        Case 101&: strReturn = "Attachment"         'dbAttachment
        Case 102&: strReturn = "Complex Byte"       'dbComplexByte
        Case 103&: strReturn = "Complex Integer"    'dbComplexInteger
        Case 104&: strReturn = "Complex Long"       'dbComplexLong
        Case 105&: strReturn = "Complex Single"     'dbComplexSingle
        Case 106&: strReturn = "Complex Double"     'dbComplexDouble
        Case 107&: strReturn = "Complex GUID"       'dbComplexGUID
        Case 108&: strReturn = "Complex Decimal"    'dbComplexDecimal
        Case 109&: strReturn = "Complex Text"       'dbComplexText
        Case Else: strReturn = "Field type " & fld.Type & " unknown"
    End Select
    
    FieldTypeName = strReturn
End Function

Ex19: VBA - Read table records using DAO

How to read the field names and types from a table or query.

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function ShowFieldsRS(strTable)
    'Purpose:   How to read the field names and types from a table or query.
    'Usage:     Call ShowFieldsRS("Table1")
    Dim rs As DAO.Recordset
    Dim fld As DAO.Field
    Dim strSql As String
    
    strSql = "SELECT " & strTable & ".* FROM " & strTable & " WHERE (False);"
    Set rs = DBEngine(0)(0).OpenRecordset(strSql)
    For Each fld In rs.Fields
        Debug.Print fld.Name, FieldTypeName(fld), "from " & fld.SourceTable & "." & fld.SourceField
    Next
    rs.Close
    Set rs = Nothing
End Function

Ex18: VBA - Read fields using DAO

How to read the fields of a table using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function ShowFields(strTable As String)
    'Purpose:   How to read the fields of a table.
    'Usage:     Call ShowFields("Table1")
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    
    Set db = CurrentDb()
    Set tdf = db.TableDefs(strTable)
    For Each fld In tdf.Fields
        Debug.Print fld.Name, FieldTypeName(fld)
    Next
    
    Set fld = Nothing
    Set tdf = Nothing
    Set db = Nothing
End Function

Ex17: VBA - Show DB properties using DAO

List the properties of the current database using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function ShowDatabaseProps()
    'Purpose:   List the properies of the current database.
    Dim db As DAO.Database
    Dim prp As DAO.Property
    
    Set db = CurrentDb()
    For Each prp In db.Properties
        Debug.Print prp.Name
    Next
    
    Set db = Nothing
End Function

Ex16: VBA - Create new database using DAO

Create a new database programmatically, and set its key properties using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function CreateDatabaseDAO()
    'Purpose:   How to create a new database and set key properties.
    Dim dbNew As DAO.Database
    Dim prp As DAO.Property
    Dim strFile As String
    
    'Create the new database.
    strFile = "C:\SampleDAO.mdb"
    Set dbNew = DBEngine(0).CreateDatabase(strFile, dbLangGeneral)
    
    'Create example properties in new database.
    With dbNew
        Set prp = .CreateProperty("Perform Name AutoCorrect", dbLong, 0)
        .Properties.Append prp
        Set prp = .CreateProperty("Track Name AutoCorrect Info", _
            dbLong, 0)
        .Properties.Append prp
    End With
    
    'Clean up.
    dbNew.Close
    Set prp = Nothing
    Set dbNew = Nothing
    Debug.Print "Created " & strFile
End Function

Ex15: VBA - Create a query using DAO

Create a query programmatically using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function CreateQueryDAO()
    'Purpose:   How to create a query
    'Note:      Requires a table named MyTable.
    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    
    Set db = CurrentDb()
    
    'The next line creates and automatically appends the QueryDef.
    Set qdf = db.CreateQueryDef("qryMyTable")
    
    'Set the SQL property to a string representing a SQL statement.
    qdf.SQL = "SELECT MyTable.* FROM MyTable;"
    
    'Do not append: QueryDef is automatically appended!

    Set qdf = Nothing
    Set db = Nothing
    Debug.Print "qryMyTable created."
End Function

Ex14: VBA - Index on field using DAO

Indicate if there is a single-field index using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Private Function IndexOnField(tdf As DAO.TableDef, fld As DAO.Field) _
As Integer
    'Purpose:   Indicate if there is a single-field index _
    '               on this field in this table.
    'Return:    The constant indicating the strongest type.
    Dim ind As DAO.Index
    Dim intReturn As Integer
    
    intReturn = intcIndexNone
    
    For Each ind In tdf.Indexes
        If ind.Fields.Count = 1 Then
            If ind.Fields(0).Name = fld.Name Then
                If ind.Primary Then
                    intReturn = (intReturn Or intcIndexPrimary)
                ElseIf ind.Unique Then
                    intReturn = (intReturn Or intcIndexUnique)
                Else
                    intReturn = (intReturn Or intcIndexGeneral)
                End If
            End If
        End If
    Next
    
    'Clean up
    Set ind = Nothing
    IndexOnField = intReturn
End Function

Ex13: VBA - Set field description using DAO

Assign a Description to a field using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function SetFieldDescription(tdf As DAO.TableDef, fld As DAO.Field, _
Optional ByVal strDescrip As String, Optional strErrMsg As String) _
As Boolean
    'Purpose:   Assign a Description to a field.
    'Arguments: tdf = the TableDef the field belongs to.
    '           fld = the field to document.
    '           strDescrip = The description text you want.
    '                        If blank, uses Caption or Name of field.
    '           strErrMsg  = string to append any error messages to.
    'Notes:     Description includes field size, validation,
    '               whether required or unique.
    
    If (fld.Attributes And dbAutoIncrField) > 0& Then
        strDescrip = strDescrip & " Automatically generated " & _
            "unique identifier for this record."
    Else
        'If no description supplied, use the field's Caption or Name.
        If Len(strDescrip) = 0& Then
            If HasProperty(fld, "Caption") Then
                If Len(fld.Properties("Caption")) > 0& Then
                    strDescrip = fld.Properties("Caption") & "."
                End If
            End If
            If Len(strDescrip) = 0& Then
                strDescrip = fld.Name & "."
            End If
        End If
        
        'Size of the field.
        'Ignore Date, Memo, Yes/No, Currency, Decimal, GUID,
        '   Hyperlink, OLE Object.
        Select Case fld.Type
        Case dbByte, dbInteger, dbLong
            strDescrip = strDescrip & " Whole number."
        Case dbSingle, dbDouble
            strDescrip = strDescrip & " Fractional number."
        Case dbText
            strDescrip = strDescrip & " " & fld.Size & "-char max."
        End Select
        
        'Required and/or Unique?
        'Check for single-field index, and Required property.
        Select Case IndexOnField(tdf, fld)
        Case intcIndexPrimary
            strDescrip = strDescrip & " Required. Unique."
        Case intcIndexUnique
            If fld.Required Then
                strDescrip = strDescrip & " Required. Unique."
            Else
                strDescrip = strDescrip & " Unique."
            End If
        Case Else
            If fld.Required Then
                strDescrip = strDescrip & " Required."
            End If
        End Select
        
        'Validation?
        If Len(fld.ValidationRule) > 0& Then
            If Len(fld.ValidationText) > 0& Then
                strDescrip = strDescrip & " " & fld.ValidationText
            Else
                strDescrip = strDescrip & " " & fld.ValidationRule
            End If
        End If
    End If
    
    If Len(strDescrip) > 0& Then
        strDescrip = Trim$(Left$(strDescrip, 255&))
        SetFieldDescription = SetPropertyDAO(fld, "Description", _
            dbText, strDescrip, strErrMsg)
    End If
End Function

Ex12: VBA - Proper() function using DAO

Convert mixed case name into a name with spaces using DAO in VBA

Option Compare Database
Option Explicit

'Constants for examining how a field is indexed.
Private Const intcIndexNone As Integer = 0
Private Const intcIndexGeneral As Integer = 1
Private Const intcIndexUnique As Integer = 3
Private Const intcIndexPrimary As Integer = 7

Function ConvertMixedCase(ByVal strIn As String) As String
    'Purpose:   Convert mixed case name into a name with spaces.
    'Argument:  String to convert.
    'Return:    String converted by these rules:
    '           1. One space before an upper case letter.
    '           2. Replace underscores with spaces.
    '           3. No spaces between continuing upper case.
    'Example:   "FirstName" or "First_Name" => "First Name".
    Dim lngStart As Long        'Loop through string.
    Dim strOut As String        'Output string.
    Dim boolWasSpace As Boolean 'Last char. was a space.
    Dim boolWasUpper As Boolean 'Last char. was upper case.
    
    strIn = Trim$(strIn)        'Remove leading/trailing spaces.
    boolWasUpper = True         'Initialize for no first space.
    
    For lngStart = 1& To Len(strIn)
        Select Case Asc(Mid(strIn, lngStart, 1&))
        Case vbKeyA To vbKeyZ   'Upper case: insert a space.
            If boolWasSpace Or boolWasUpper Then
                strOut = strOut & Mid(strIn, lngStart, 1&)
            Else
                strOut = strOut & " " & Mid(strIn, lngStart, 1&)
            End If
            boolWasSpace = False
            boolWasUpper = True
            
        Case 95                 'Underscore: replace with space.
            If Not boolWasSpace Then
                strOut = strOut & " "
            End If
            boolWasSpace = True
            boolWasUpper = False
            
        Case vbKeySpace         'Space: output and set flag.
            If Not boolWasSpace Then
                strOut = strOut & " "
            End If
            boolWasSpace = True
            boolWasUpper = False
            
        Case Else               'Any other char: output.
            strOut = strOut & Mid(strIn, lngStart, 1&)
            boolWasSpace = False
            boolWasUpper = False
        End Select
    Next
    
    ConvertMixedCase = strOut
End Function