Public Sub faGetStructure(strDB as String)
'запомнить информацию о структуре базы данных в специальных таблицах
'strDB - это полный путь к базе данных, у которой сохраняем информацию о структуре
Dim cat As ADOX.Catalog
Dim tbl As ADOX.Table
Dim idx As ADOX.Index
Dim ky As ADOX.Key
Dim clm As ADOX.Column
Dim prp As ADOX.Property
Dim rstTables As ADODB.Recordset
Dim rst As ADODB.Recordset
Dim rstPrp As ADODB.Recordset
Dim lngID As Long
If strDB = vbNullString Then Exit Sub 'если не выбрали файл, то выходим
Set cat = New ADOX.Catalog
cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strDB & ";"
Set rstPrp = New ADODB.Recordset
rstPrp.Open "PropertiesT", CurrentProject.Connection, adOpenKeyset, adLockOptimistic, adCmdTableDirect
Set rstTables = New ADODB.Recordset
With rstTables
.Open "Structure", CurrentProject.Connection, adOpenKeyset, adLockOptimistic, adCmdTableDirect
'если списка таблиц нет, то его надо создать
If .RecordCount = 0 Then
'вызываем функцию для создания списка таблиц сохраняемой базы данных
faGetTableList cat, rstTables
End If
Set rst = New ADODB.Recordset
Do Until .EOF 'цикл по всем таблицам в списке
rst.Open "ColumnsT", CurrentProject.Connection, adOpenDynamic, adLockOptimistic, adCmdTableDirect
For Each tbl In cat.Tables'заполнение столбцов таблиц
If tbl.Name = .Fields("Table") Then
For Each clm In tbl.Columns
rst.AddNew
rst.Fields("Table") = .Fields("ID")
rst.Fields("Name") = clm.Name
rst.Fields("Type") = clm.Type
rst.Fields("Size") = clm.DefinedSize
rst.Fields("Attributes") = clm.Attributes
rst.Fields("Key") = clm.Properties("AutoIncrement")
rst.Update
For Each prp In clm.Properties
rstPrp.AddNew
rstPrp.Fields("ColumnT") = rst.Fields("ID")
rstPrp.Fields("Name") = prp.Name
rstPrp.Fields("Type") = prp.Type
rstPrp.Fields("Value") = prp.Value
rstPrp.Update
Next
Next
Set rst = Nothing
Set rst = New ADODB.Recordset
'rst.Close
For Each idx In tbl.Indexes
rst.Open "Indexes", CurrentProject.Connection, adOpenDynamic, adLockOptimistic, adCmdTableDirect
If idx.Name = "PrimaryKey" Then
rst.AddNew
rst.Fields("Table") = .Fields("ID")
rst.Fields("Name") = idx.Name
rst.Fields("PrimaryKey") = idx.PrimaryKey
rst.Fields("Unique") = idx.Unique
rst.Update
lngID = rst.Fields("ID")
rst.Close
rst.Open "ColumnsI", CurrentProject.Connection, adOpenDynamic, adLockOptimistic, adCmdTableDirect
For Each clm In idx.Columns
rst.AddNew
rst.Fields("Index") = lngID
rst.Fields("Name") = clm.Name
rst.Update
Next
End If
rst.Close
Next
For Each ky In tbl.Keys
rst.Open "Keys", CurrentProject.Connection, adOpenDynamic, adLockOptimistic, adCmdTableDirect
If ky.Name <> "PrimaryKey" Then
rst.AddNew
rst.Fields("Table") = .Fields("ID")
rst.Fields("Name") = ky.Name
rst.Fields("Type") = ky.Type
rst.Fields("RelatedTable") = ky.RelatedTable
rst.Fields("UpdateRule") = ky.UpdateRule
rst.Fields("DeleteRule") = ky.DeleteRule
rst.Update
lngID = rst.Fields("ID")
rst.Close
rst.Open "ColumnsK", CurrentProject.Connection, adOpenDynamic, adLockOptimistic, adCmdTableDirect
For Each clm In ky.Columns
rst.AddNew
rst.Fields("Key") = lngID
rst.Fields("Name") = clm.Name
rst.Fields("RelatedColumn") = clm.RelatedColumn
rst.Update
Next
End If
rst.Close
Next
End If
Next
.MoveNext
Loop
End With
End Sub
Public Sub faGetTableList(cat As ADOX.Catalog, rst As ADODB.Recordset)
'сохранение списка таблиц открытой базы (каталог ADOX) в наборе записей rst
On Error GoTo ErrHolder
Dim tbl As ADOX.Table
With rst  
For Each tbl In cat.Tables
If tbl.Type = "TABLE" Then
.AddNew
.Fields("Table") = tbl.Name
.Update
End If
Next
.MoveFirst
End With
ExitHere:
Exit Sub
ErrHolder:
MsgBox Err.Number & ": " & Err.Description, vbExclamation, "Error"
Resume ExitHere
End Sub
Итак, для сохранения информации о структуре базы данных в таблицах, рассмотренных выше, необходимо запустить процедуру faGetStructure при этом, передав ей в качестве параметра полное имя файла базы данных, структуру которой необходимо сохранить.
Данная процедура использует вспомогательную процедуру faGetTableList в случае, если таблица Structure окажется пустой. Вспомогательная процедура заполнит данную таблицу названиями всех таблиц из сохраняемой базы данных. Можно использовать данную особенность для того, чтобы сохранить информацию не о всей структуре базы данных, а только о части, представленной определёнными таблицами, для этого нужно вручную заполнить таблицу Structure названиями таблиц сохраняемой структуры.
Процедура faGetStructure для каждого наименования таблицы из Structure сохранит в таблицах информацию о столбцах и их свойствах таблиц, индексов, ключей.
Таким образом, мы сохранили информацию о структуре базы данных и можем использовать эту информацию многократно. Если структура базы данных поменяется, то достаточно удалить всю информацию из таблицы Structure и заново вызвать процедуру faGetStructure.

Коррекция сохранённой структуры

Сохранённая информация о структуре требует коррекции, иначе могут возникнуть ошибки при создании новой базы данных. Коррекция заключается в удалении из таблицы PropertiesT свойств столбцов таблицы всех полей, относящихся к свойствам с именами “Seed” (насколько могу судить: значение идентификатора для первой строки таблицы) и “Increment” (приращение для столбца идентификатора), т.к. эти свойства невозможно установить программно, как выяснилось эмпирически. На счёт свойства “Increment” могу предположить, что его нельзя задать, т.к. MS Access (Jet) признаёт любые значения “Increment”, при условии, что они равны 1 (единице). Из-за того, что необходимость коррекции выяснилась эмпирическим способом, она не отражена в коде, представленном в Листинге 1. Для проведения этой коррекции можно использовать такой запрос:
DELETE PropertiesT.Name
FROM PropertiesT
WHERE (((PropertiesT.Name)="Seed" Or (PropertiesT.Name)="Increment"));

Также требуется подкорректировать значения свойства “Nullable” у столбцов с логическим типом данных: оно должно быть всегда равно нулю. Этой корректировки также нет в Листинге 1, для этой цели можно использовать такой запрос:
UPDATE ColumnsT INNER JOIN PropertiesT ON ColumnsT.ID = PropertiesT.ColumnT SET PropertiesT.[Value] = "0"
WHERE (((ColumnsT.Type)=11) AND ((PropertiesT.Name)="Nullable"));

Также эмпирическим путём выяснилось, что для свойства “Fixed Length” («фиксированная длина») ключевых полей с числовым типом данных не может быть значение “False” («ложь»), хотя по неизвестным причинам при сохранении такое значение этого свойства записывается. Поэтому для данного случая также требуется коррекция. В виде запроса эта коррекция выглядит следующим образом:
UPDATE ColumnsT INNER JOIN PropertiesT ON ColumnsT.ID = PropertiesT.ColumnT SET PropertiesT.[Value] = "-1"
WHERE (((PropertiesT.Value)="0") AND ((ColumnsT.Type)=3) AND ((ColumnsT.Key)=True) AND ((PropertiesT.Name)="Fixed Length"));

Само собой разумеется, что значение свойства “JET OLEDB:Allow Zerro Length” («допускается нулевая длина») для ключевых полей с числовым типом данных не может быть “True” («истина»), но и такое бывает, поэтому и для этого варианта предусматриваем коррекцию в виде запроса:
UPDATE ColumnsT INNER JOIN PropertiesT ON ColumnsT.ID = PropertiesT.ColumnT SET PropertiesT.[Value] = "0"
WHERE (((PropertiesT.Value)="-1") AND ((ColumnsT.Type)=3) AND ((ColumnsT.Key)=True) AND ((PropertiesT.Name)="Jet OLEDB:Allow Zero Length"));

Эту коррекцию можно легко внедрить в код сохранения информации о структуре базы данных в виде вызова отдельных процедур.
Ещё одно замечание. Если в сохраняемой структуре базы данных были пользовательские таблицы с именами, начинающимися на “MSys”, как у системных таблиц Access, то при сохранении таблицы программно возникнет ошибка. Поэтому перед созданием базы данных по сохранённой структуре, нужно изменить название таких таблиц в таблице Structure. А после создания базы данных переименовать эти таблицы обратно.

Создание новой базы данных по сохранённой структуре

Теперь можно создавать неограниченное число раз чистых копий баз данных, аналогичных по структуре исходной, информация о которой была сохранена и скорректирована.
В Листинге 2 представлен код для создания базы данных по уже сохранённой структуре.

Листинг 2

Public Function faCreateStructure(strDB As String) As Boolean
'создание файла базы данных с сохранённой структурой
On Error GoTo ErrHolder

Dim cat As ADOX.Catalog
Dim tbl As ADOX.Table
Dim idx As ADOX.Index
Dim ky As ADOX.Key
Dim clm As ADOX.Column
Dim prp As ADOX.Property
Dim rst As ADODB.Recordset
Dim rstClm As ADODB.Recordset
Dim rstTables As ADODB.Recordset
Dim rstPrp As ADODB.Recordset

If strDB <> vbNullString Then

Set cat = New ADOX.Catalog
cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strDB & ";"

Set rstTables = New ADODB.Recordset
Set rstClm = New ADODB.Recordset
Set rst = New ADODB.Recordset
Set rstPrp = New ADODB.Recordset

With rstTables
.Open "Structure", CurrentProject.Connection, , , adCmdTableDirect
Do Until .EOF
Set tbl = New ADOX.Table
rstClm.Open _
"SELECT * FROM ColumnsT WHERE ColumnsT.Table=" & .Fields("ID"), _
CurrentProject.Connection, , , adCmdText
tbl.Name = .Fields("Table")
Do Until rstClm.EOF
'добавление столбцов
Set clm = New ADOX.Column
clm.Name = rstClm.Fields("Name")
clm.Type = rstClm.Fields("Type")
If rstClm.Fields("Size") > 0 Then
clm.DefinedSize = rstClm.Fields("Size")
End If
tbl.Columns.Append clm
rstClm.MoveNext
Loop
'заполнение свойств столбцов
rstClm.MoveFirst
Do Until rstClm.EOF
Set clm = tbl.Columns("" & rstClm.Fields("Name") & "")
Call faSetPropertiesC(cat, clm, rstClm.Fields("ID"))
rstClm.MoveNext
Loop
rstClm.Close
'присоединение таблицы
cat.Tables.Append tbl
.MoveNext
Loop
'добавление индексов к таблицам
.MoveFirst
Do Until .EOF
Set tbl = cat.Tables("" & .Fields("Table") & "")
rst.Open _
"SELECT * FROM Indexes WHERE Indexes.Table=" & .Fields("ID"), _
CurrentProject.Connection, , , adCmdText
Do Until rst.EOF
Set idx = New ADOX.Index
idx.Name = rst.Fields("Name")
idx.PrimaryKey = rst.Fields("PrimaryKey")
idx.Unique = rst.Fields("Unique")
'присоединение столбцов
rstClm.Open _
"SELECT * FROM ColumnsI WHERE ColumnsI.Index=" & rst.Fields("ID"), _
CurrentProject.Connection, , , adCmdText
Do Until rstClm.EOF
idx.Columns.Append "" & rstClm.Fields("Name") & ""
rstClm.MoveNext
Loop
tbl.Indexes.Append idx
rst.MoveNext
rstClm.Close
Loop
rst.Close
.MoveNext
Loop
'добавление ключей (связей) таблиц
.MoveFirst
Do Until .EOF
Set tbl = cat.Tables("" & .Fields("Table") & "")
rst.Open _
"SELECT * FROM Keys WHERE Keys.Table=" & .Fields("ID"), _
CurrentProject.Connection, , , adCmdText
Do Until rst.EOF
Set ky = New ADOX.Key
ky.Name = rst.Fields("Name")
ky.Type = rst.Fields("Type")
ky.RelatedTable = rst.Fields("RelatedTable")
'присоединение столбцов
rstClm.Open _
"SELECT * FROM ColumnsK WHERE ColumnsK.Key=" & rst.Fields("ID"), _
CurrentProject.Connection, , , adCmdText
Do Until rstClm.EOF
ky.Columns.Append "" & rstClm.Fields("Name") & ""
If Not IsNull(rstClm.Fields("RelatedColumn")) Then
ky.Columns("" & rstClm.Fields("Name") & "").RelatedColumn = rstClm.Fields("RelatedColumn")
End If
rstClm.MoveNext
Loop
ky.UpdateRule = rst.Fields("UpdateRule")
ky.DeleteRule = rst.Fields("DeleteRule")
tbl.Keys.Append ky
rst.MoveNext
rstClm.Close
Loop
.MoveNext
rst.Close
Loop
End With

faCreateStructure = True

End If

ExitHere:
Set tbl = Nothing
Set idx = Nothing
Set ky = Nothing
cat.ActiveConnection.Close
Set cat = Nothing
Exit Function
ErrHolder:
Select Case Err.Number
Case -2147217868 'индекс уже существует
Resume Next
Case Else
faCreateStructure = False
MsgBox Err.Number & ": " & Err.Description, vbExclamation
Resume ExitHere
End Select
End Function

Public Function faSetPropertiesC(ByRef cat As ADOX.Catalog, _
ByRef clm As ADOX.Column, ID As Long) As Boolean
'заполнение свойств столбцов таблицы
On Error GoTo ErrHolder

Dim prp As ADOX.Property
Dim rstClm As ADODB.Recordset
Dim rstTables As ADODB.Recordset
Dim rstPrp As ADODB.Recordset

Set rstTables = New ADODB.Recordset
Set rstClm = New ADODB.Recordset
Set rstPrp = New ADODB.Recordset

clm.ParentCatalog = cat
rstPrp.Open _
"SELECT * FROM PropertiesT WHERE PropertiesT.ColumnT=" & ID, _
CurrentProject.Connection, , , adCmdText
Do Until rstPrp.EOF
Select Case rstPrp.Fields("Type")
Case adBoolean
If CBool(rstPrp.Fields("Value")) Then
clm.Properties("" & rstPrp.Fields("Name") & "") = True
Else
clm.Properties("" & rstPrp.Fields("Name") & "") = False
End If
Case adInteger
clm.Properties("" & rstPrp.Fields("Name") & "") = _
CLng(rstPrp.Fields("Value"))
Case adVariant
clm.Properties("" & rstPrp.Fields("Name") & "") = _
CVar(rstPrp.Fields("Value"))
Case Else
clm.Properties("" & rstPrp.Fields("Name") & "") = _
rstPrp.Fields("Value")
End Select
rstPrp.MoveNext
Loop
Debug.Print clm.Name
For Each prp In clm.Properties
Debug.Print prp.Name & ": "; prp.Value
Next
rstPrp.Close
faSetPropertiesC = True
ExitHere:
Set prp = Nothing
Exit Function
ErrHolder:
Select Case Err.Number
Case -2147217868 'индекс уже существует
Resume Next
Case Else
faSetPropertiesC = False
MsgBox Err.Number & ": " & Err.Description, vbExclamation
Resume ExitHere
End Select
End Function

Для создания новой пустой базы данных сохранённой структуры нужно вызвать процедуру faCreateStructure и передать ей в качестве параметра полное имя файла создаваемой базы данных.
Сначала эта процедура создаёт новую базу данных как каталог ADOX, затем, используя информацию из таблиц, создаёт каждую таблицу, столбцы и заполняет их свойства. Для заполнения свойств столбцов используется вспомогательная процедура faSetPropertiesC. Данная процедура заполняет свойства, согласуясь с типом самого свойства.
Далее процедура создаёт и заполняет свойства индексов и ключей таблиц базы данных.
В результате получаем копию сохранённой базы данных, но без данных.