MI HAYATUL ISLAM: VBA

Breaking News

Showing posts with label VBA - ADOX. Show all posts

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