Sub CreateNewFieldWithAttributes()
On Error GoTo AttributesXError

Dim cnn As New ADODB.Connection
Dim cat As New ADOX.Catalog
Dim col As New ADOX.Column
Dim rst As New ADODB.Recordset
Dim tbl As ADOX.Table
Dim strMessage As String
Dim strInput As String

' Connect the catalog.
cnn.Open "Provider='Microsoft.Jet.OLEDB.4.0';" & _
 "Data Source=C:\Program Files\Microsoft Office\OFFICE11\SAMPLES\Northwind.mdb;"
Set cat.ActiveConnection = cnn      ' Make a catalog for the database.
Set tbl = cat.Tables("Employees")   ' Get the table.

' Create a new Field object 'Fax' and append it to the Fields collection of the Employees table.
col.Name = "Fax"
col.Type = adVarWChar
col.DefinedSize = 12
col.Attributes = adColNullable
cat.Tables("Employees").Columns.Append col.Name, adWChar, 12

' Open the Employees table for updating as a Recordset.
rst.Open "Employees", cnn, adOpenKeyset, adLockOptimistic, adCmdTable

With rst
' Get user input.
strMessage = "Enter fax number for " & !FirstName & " " & !LastName & "." & vbCr & _
"[? = unknown, NA = no fax]"
strInput = UCase(InputBox(strMessage))
   If strInput <> "" Then
      Select Case strInput
         Case "?"
            !Fax = Null
         Case "NA"
            !Fax = ""
         Case Else
            !Fax = strInput
      End Select
      .Update

' Print report.
Debug.Print "Name & Fax number"
Debug.Print !FirstName & " " & !LastName & " - ";

   If IsNull(!Fax) Then
      Debug.Print "[Unknown]"
   Else
      If !Fax = "" Then
         Debug.Print "[Has no fax]"
      Else
         Debug.Print !Fax
      End If
   End If
End If
.Close
End With

' Drop the field. It's just a test.
tbl.Columns.Delete "Fax"
'Or, tbl.Columns.Delete col.Name

' Clean up objects.
cnn.Close
Set rst = Nothing
Set cat = Nothing
Set col = Nothing
Set cnn = Nothing
Exit Sub

AttributesXError:
   If Not rst Is Nothing Then
      If rst.State = adStateOpen Then rst.Close
   End If
   Set rst = Nothing

   If Not tbl Is Nothing Then
      tbl.Columns.Delete col.Name
   End If
   Set cat = Nothing
   Set col = Nothing

   If Not cnn Is Nothing Then
      If cnn.State = adStateOpen Then
         cnn.Close
      End If
   End If
   Set cnn = Nothing

   If Err <> 0 Then
      MsgBox Err.Source & "-->" & Err.Description, , "Error"
   End If
End Sub
 

Go To Top

'Purpose: To create a new security group, add users and passwords, update access permissions.

Sub CreateGroupAndUsers()
Dim cat As New ADOX.Catalog
Dim strOwner As String

' Connect the catalog pointing to this database.
Set cat.ActiveConnection = CurrentProject.Connection

' Add a group named 'Planning'.
cat.Groups.Append "Planning"

' Add the Admin in this group.
cat.Groups("Planning").Users.Append "Admin"

' Add a User named 'William' and password 'kuching'.
cat.Users.Append "William", "kuching"

' Add the user in the Planning group.
cat.Users("William").Groups.Append "Planning"

' Change user's password.
cat.Users("William").ChangePassword "Kuching", "Cat"

' Show the current owner of the 'Orders' table.
strOwner = cat.GetObjectOwner("Orders", adPermObjTable)
Debug.Print "Orders table is owned by " & strOwner

' Display permissions of current owner of the 'Orders' table. Refer to RightsEnum Constants.
Debug.Print "Full permissions: " & _
str(cat.Users("admin").GetPermissions("Orders", adPermObjTable))

' Change the ownership.
cat.SetObjectOwner "Orders", adPermObjTable, "William"
Debug.Print "Orders table is now owned by William"

' Grant user full access right permissions on the 'Orders' table.
cat.Users("William").SetPermissions "Orders", adPermObjTable, adAccessSet, adRightFull

' these 2 lines are to delete user's account and group 'Planning'.
cat.Users.Delete ("William")
cat.Groups.Delete ("Planning")

' Or alternatively, use this line to revoke only all permissions to the user.
'cat.Users("William").SetPermissions "Orders", adPermObjTable, adAccessRevoke, adRightFull

' Set ownership back to Admin with full access permissions.
cat.SetObjectOwner "Orders", adPermObjTable, "Admin"
cat.Users("Admin").SetPermissions "Orders", adPermObjTable, adAccessSet, adRightFull
End Sub

Go To Top

'Purpose: To create, update or to delete Views.

Sub CreateUpdateProcedure()
Dim cnn As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim cat As New ADOX.Catalog
Dim viw As ADOX.View

'Open the Connection
cnn.Open _
"Provider='Microsoft.Jet.OLEDB.4.0'; " & _
"Data Source=C:\Program Files\Microsoft Office\OFFICE11\SAMPLES\Northwind.mdb;"

'Open the Catalog
Set cat.ActiveConnection = cnn

'Create the parameterized command text (Microsoft Jet specific)
Set cmd.ActiveConnection = cnn
cmd.CommandText = "PARAMETERS [CustID] Text;" _
& "SELECT * FROM Customers WHERE CustomerID = [CustID]"

'Create the new Procedure
cat.Procedures.Append "qry_CustomerByID", cmd     ' or use cat.Views.Append "qry_CustomerByID", cmd

'use the Command property to update the text of a procedure.
Set cmd = cat.Procedures("qry_CustomerByID").Command     ' Get the command.
cmd.CommandText = "SELECT * FROM Customers WHERE CustomerID = 'ANTON'"  ' Update the CommandText.
Set cat.Procedures("qry_CustomerByID").Command = cmd   ' Update the procedure.

'To obtain all views in the catalog
For Each objView In cat.Views
   Debug.Print viw.Name
Next

cat.Views.Delete "qry_CustomerByID"  ' Delete the procedure as it's only testing

'Clean up objects
cnn.Close
Set cmd = Nothing
Set cat = Nothing
Set cnn = Nothing
End Sub
 

Go To Top

'Purpose: To modify/delete tables, procedures, columns, fields, indexes, keys, users and group.

Sub Deletes()
Dim cnn As New ADODB.Connection
Dim cat As New ADOX.Catalog
Dim tbl As New ADOX.Table
Dim col As New ADOX.Column
Dim cmd As New ADODB.Command
Dim ind As New ADOX.Index
Dim ky As New ADOX.Key
Dim prp As ADOX.Property

' Connect the catalog to the current database
cat.ActiveConnection = CurrentProject.Connection

' Add a new table and two fields
tbl.Name = ("My_Table")
tbl.Columns.Append "Field1", adInteger
With col
   .Name = "My_Field"
   .Type = adNumeric 'Decimal data type
   .Precision = 16 '28 digits
   .NumericScale = 4 '8 decimal places
End With
tbl.Columns.Append col
cat.Tables.Append tbl

' Modify the column properties
Set col = cat.Tables("My_Table").Columns("My_Field")    ' Point column object to the field
Set prp = col.Properties("Nullable")                    ' Set column property to null
Debug.Print prp.Name, prp.Value, prp.Attributes, (prp.Type = adBoolean)  ' Print the property
col.Properties("Jet OLEDB:Allow Zero Length") = False   ' Change to disallow zero-length

' Create a primary key index
Set tbl = cat.Tables("My_Table")
Set ind = New ADOX.Index
ind.Name = "PrimaryKey"
ind.PrimaryKey = True
ind.Columns.Append "My_Field"
tbl.Indexes.Append ind

' Retrieve the foreign key table
Set tbl = cat.Tables("My_Table2")
' Create as foreign key to Table2.Field2
Set ky = New ADOX.Key
With ky
   .Name = "My_Table2Key"
   .Type = adKeyForeign
   .RelatedTable = "My_Table"
   .Columns.Append "My_Field2"
   .Columns("My_Field2").RelatedColumn = "My_Field"
   .DeleteRule = adRISetNull   ' Cascade to Null on delete
End With
tbl.Keys.Append ky

' Create the command and the new view
cmd.CommandText = "Select * From My_Table"
cat.Views.Append "My_Query", cmd

cat.Groups.Append "Planning"
cat.Users.Append "William"
cat.Users("William").Groups.Append "Planning"

cat.Tables("My_Table2").Keys.Delete ky.Name         ' Delete the foreign key
cat.Tables("My_Table").Indexes.Delete "Primarykey"  ' Delete the index
cat.Views.Delete "My_Query"     ' Delete the query
cat.Tables.Delete "My_Table"    ' Delete the table
cat.Users.Delete ("William")    ' Delete the user account
cat.Groups.Delete ("Planning")  ' Delete the group account

' Clean up the objects
Set ky = Nothing
Set ind = Nothing
Set prp = Nothing
Set col = Nothing
Set tbl = Nothing
Set cat = Nothing
End Sub
 

Note:
It is wise to have a message box to prompt user for confirmation especially on deleting tables and fields. Below is an example code.

Dim cat As ADOX.Catalog
Dim tbl As New ADOX.Table
Dim input As Long

For Each tbl In cat.Tables
input = MsgBox("Do you want to delete " & tbl.Name, vbYesNo, "Delete table..."), _
    vbYesNo, "Confirm table delete")
    If input = vbYes Then
         input = MsgBox("Are you sure you want to PERMANENTLY delete " & tbl.Name _
         & "from the database?", vbYesNo, "Confirm delete...")
         If input = vbYes Then
                DoCmd.DeleteObject acTable, tbl.Name
               "MsgBox "Table deleted"   
         End If
    End If
Next tbl
 

Go To Top

Sub RetrieveWorkbooksSchema()
Dim cnn As New ADODB.Connection
Dim cat As New ADOX.Catalog
Dim adoTable As ADOX.Table
Dim adoTables As ADOX.Tables
Dim path As String

path = "C:\MySheet.xls"  ' change your path and workbook name

' Connection string to Excel
cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & path & _
  ";Extended Properties=""Excel 8.0;HDR=Yes;"""
' Open the connection
cnn.Open

' Treat the workbook as a database catalog
cat.ActiveConnection = cnn

' Get the catalogs tables, which in this case is the worksheets
Set adoTables = cat.Tables

' Print a count of the worksheets
Debug.Print "No. of worksheets: " & adoTables.Count

' For each table/sheet in the catalog/workbook display the name
For Each adoTable In adoTables
   Debug.Print adoTable.Name
Next

' Close the connection
cnn.Close
' Clean up objects
Set cnn = Nothing
Set cat = Nothing
Set adoTables = Nothing
Set adoTable = Nothing
End Sub
 

Go To Top

'Purpose: another Visual Basic example that gets Excel spreadsheet schema and print into an array _ using ADOX objects.

Sub RetrieveWorkbooksSchema2()
Dim cnn As New ADODB.Connection
Dim cat As New ADOX.Catalog
Dim tbl As ADOX.Table
Dim col As ADOX.Column
Dim strCnn As String

Dim iTbl As Integer, iCol As Integer
Dim strColNames(1 To 100, 1 To 1000) As String  ' a two-dimensional array assigns two indexes to each element

strCnn = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=C:\MySheet.xls;" & _
"Extended Properties=""Excel 8.0; HDR=YES; IMEX=1"""
cnn.Open strCnn
cat.ActiveConnection = cnn

iTbl = 0
iCol = 0
For Each tbl In cat.Tables
iTbl = iTbl + 1
   For Each col In tbl.Columns
      iCol = iCol + 1
      strColNames(iTbl, iCol) = tbl.Name & col.Name
      Debug.Print tbl.Name & ": " & col.Name
   Next col
Next tbl
End Sub

Go To Top

'Purpose: To Show the columns in a table, and optionally their properties, using ADOX.

Function ShowTableProperties(strTable As String, Optional ShowProperties As Boolean)
Dim cat As New ADOX.Catalog
Dim tbl As ADOX.Table
Dim col As ADOX.Column
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
      If ShowProperties Then
         For Each prp In col.Properties
            Debug.Print , prp.Name, prp.Type, prp.Attributes, prp.Value
         Next
            Debug.Print "---------------------"
      End If
Next

'Clean up objects
Set prp = Nothing
Set col = Nothing
Set tbl = Nothing
Set cat = Nothing
End Function
 

Go To Top

This site was created in February 2007 by William Tan