ADOX в ACCESS

Public Sub ADOXListTables()
'список всех таблиц БД с указанием типа таблицы
Dim adoxCat As ADOX.Catalog
Dim adoxTbl As ADOX.Table
Dim strType As String
Set adoxCat = New ADOX.Catalog

'получаем ссылку на текущую БД
adoxCat.ActiveConnection = CurrentProject.Connection
' проверяем свойство TYPE у всех объектов Table
   For Each adoxTbl In adoxCat.Tables
     Select Case adoxTbl.Type
      Case "LINK" ' связанная таблица JET
        strType = " - связанная таблица JET"
      Case "TABLE" ' обычная таблица
        strType = " - простая таблица"
      Case "ACCESS TABLE" 'системная таблица ACCESS
        strType = "- системная таблица MSA"
      Case "SYSTEM TABLE" 'системная таблица JET
        strType = " - системная таблица JET"
      Case "PASS-THROUGH" 'Связанная таблица ODBC
        strType = " - Связанная таблица ODBC"
      Case Else ' какая-то другая
        strType = " - какая-то другая таблица"
    End Select
      Debug.Print adoxTbl.Name; strType
   Next
Set adoxCat = Nothing
Set adoxTbl = Nothing
End Sub

Public Sub ADOXCreateLinkTable(strFileName As String, _
                                strTblName As String, _
                                Optional strLinkTblName As String = "")
'создание связанной таблицы MS ACCESS
'strFileName - путь к БД ACCESS, в которой находится таблица
'strTblName - имя таблицы в исходной БД
'strLinkTblName - имя, под которым будет создана связанная таблица
'если strLinkTblName опущено, то создается таблица с именем strFileName
Dim adoxCat As ADOX.Catalog
Dim adoxTbl As New ADOX.Table
Dim strType As String
Set adoxCat = New ADOX.Catalog
'получаем ссылку на текущую БД
adoxCat.ActiveConnection = CurrentProject.Connection
If strLinkTblName = "" Then strLinkTblName = strTblName
With adoxTbl
    .ParentCatalog = adoxCat
    .Name = strLinkTblName 'имя создаваемой таблицы
    'путь к файлу
    .Properties("Jet OLEDB:Link Datasource").Value = strFileName
    'имя таблицы в исходном файле
    .Properties("Jet OLEDB:Remote Table Name").Value = strTblName
    .Properties("Jet OLEDB:Create Link").Value = True
End With
adoxCat.Tables.Append adoxTbl 'добавляем таблицу в БД
Set adoxCat = Nothing
Set adoxTbl = Nothing

End Sub

Public Sub ADOXRefreshLinks(strFileName As String)
'Обновление связей всех связанных таблиц MS ACCESS
'strFileName - путь к БД ACCESS, в которой находятся таблицы
Dim adoxCat As ADOX.Catalog
Dim adoxTbl As ADOX.Table

Set adoxCat = New ADOX.Catalog
adoxCat.ActiveConnection = CurrentProject.Connection

For Each adoxTbl In adoxCat.Tables
' если таблица, связанная таблица JET
    If adoxTbl.Type = "LINK" Then
        adoxTbl.Properties("Jet OLEDB:Link Datasource") = strFileName
    End If
Next
Set adoxCat = Nothing
Set adoxTbl = Nothing
End Sub

Public Sub ADOXCreateTable()
'создание новой таблицы tblOrders с тремя полями:
'idOrder - последовательный счетчик, ключевое поле таблицы
'NumOrder - текстовое, 12 символов, с условием на значение и сообщением об ошибке
'dtOrder - дата, значение по умолчанию равно Date()
'проверка на существование таблицы и обработчик ошибок умышленно не включены для упрощения кода
Dim adoxCat As ADOX.Catalog
Dim adoxTbl As New ADOX.Table
Dim adoxCol As ADOX.Column
Set adoxCat = New ADOX.Catalog
'получаем ссылку на текущую БД
   adoxCat.ActiveConnection = CurrentProject.Connection

 With adoxTbl
    .Name = "tblOrders" 'имя таблицы
    ' создаем новый объект Column (он же поле таблицы)
    Set adoxCol = New ADOX.Column
    With adoxCol
     .ParentCatalog = adoxCat 'ссылка на каталог
     .Name = "id" 'имя поля
     .Type = adInteger 'тип поля
     .Properties("AutoIncrement").Value = True ' будет счетчик
    End With
    .Columns.Append adoxCol, adInteger ' добавляем поле в коллекцию
    'добавляем новый индекс
    .Keys.Append "PrimaryKey", adKeyPrimary, "id"

    'аналогично для всех полей таблицы
    ' поле № заказа
    Set adoxCol = New ADOX.Column
    With adoxCol
     .ParentCatalog = adoxCat
     .Name = "NumOrder"
     .Type = adVarWChar  'тип поля
     .DefinedSize = 12
     .Properties("Description").Value = "№ заказа"
     'условие на значение
     .Properties("Jet OLEDB:Column Validation Rule").Value = "<>'' and not is null"
     'сообщение о нарушении условия на значение
     .Properties("Jet OLEDB:Column Validation Text").Value = "Укажите номер заказа"
    End With
    .Columns.Append adoxCol, adVarWChar

    ' поле дата заказа
    Set adoxCol = New ADOX.Column
    With adoxCol
     .ParentCatalog = adoxCat
     .Name = "dtOrder"
     .Type = adDate 'тип поля
     .Properties("Description").Value = "Дата заказа"
     .Properties("Default").Value = "date()" ' значение по умолчанию
    End With
    .Columns.Append adoxCol, adDate


  'добавляем таблицу в БД
   adoxCat.Tables.Append adoxTbl

 End With
   Set adoxCat = Nothing
   Set adoxTbl = Nothing
   Set adoxCol = Nothing

End Sub

Public Sub ADOXListIndexTbl(strTblName As String)
'список индексов таблицы + некоторые свойства индекса +
'список полей индекса
'strTblName - имя таблицы в БД
Dim adoxCat As ADOX.Catalog
Dim adoxTbl As ADOX.Table
Dim adoxInx As ADOX.Index
Dim adoxCol As ADOX.Column
Set adoxCat = New ADOX.Catalog
adoxCat.ActiveConnection = CurrentProject.Connection

Set adoxTbl = adoxCat.Tables(strTblName)
For Each adoxInx In adoxTbl.Indexes
    With adoxInx
        Debug.Print "_________________________________"
        Debug.Print "Индекс - "; .Name
        Debug.Print "Первичный - "; .PrimaryKey
        Debug.Print "Уникальный - "; .Unique
        Debug.Print "Поля индекса : ";
        For Each adoxCol In .Columns
           Debug.Print adoxCol.Name; "; ";
        Next
        Debug.Print
    End With
Next

End Sub