Создание Пустого Клона базы данных (без данных в таблицах)

Пример использования:

Private Sub TestNewEmptyDB()
Dim srsDB As String
Dim dstDB As String
    srsDB = "d:\Temp\Temp.mdb"
    dstDB = "d:\Temp\TempEmpty.mdb"
    NewEmptyClone srsDB, dstDB

    MsgBox "Готово!"
End Sub

Private Sub NewEmptyClone(dbSoursePath As String, dbDistPath As String)
'es 20.01.2004  LE 29.10.2022 v002
'Создает копию базы данных (с пустыми таблицами) и с поледующим
'обжимом по любому заданному пути - Аргументы:
'   dbSoursePath  = Путь к исходной базе
'   dbDistPath    = Путь к новой базе
'--------------------------------------------------------------------
Dim newDB As DAO.Database
Dim wks As DAO.Workspace
Dim tdf As DAO.TableDef
Dim i As Long, x As Long
Dim str As String
Dim tempPath As String
Dim tempName As String

On Error GoTo NewEmptyCloneErr
'проверка на совпадение
    If Dir(dbSoursePath, vbNormal) = "" Then
        MsgBox "Нет исходного файла!" & vbCrLf & _
        dbSoursePath, vbCritical, "NewEmptyClone"
        Exit Sub
    End If
    If dbSoursePath = dbDistPath Then
        MsgBox "Путь назначения совпадает с исходным!" & vbCrLf & _
        dbDistPath & vbCrLf & _
        "это не допустимо!", vbCritical, "NewEmptyClone"
        Exit Sub
    End If
'Проверяем папку назначения + создаем если нет
    i = PrepareFolders(dbDistPath)
    If i <> 0 Then Exit Sub 'Конец процедуры в случае ошибки...

'ОПРЕДЕЛЯЕМ название временного файла
    'Получаем папку нового пути
    For i = Len(dbDistPath) To 1 Step -1 'Ищем самый правый слеш
        If Mid(dbDistPath, i, 1) = "\" Then Exit For
    Next i
    tempPath = Mid(dbDistPath, 1, i - 1) 'Слева до найденого слеша
    i = Len(tempPath)
    tempName = Mid(dbDistPath, i + 2) 'Назв. файла исх базы
    tempPath = tempPath & "\tmp" & tempName 'Новое название с префиксом
    'Debug.Print tempPath: Exit Sub

'Зачищаем пути - если там уже что то есть
    If Dir(dbDistPath, vbNormal) <> "" Then Kill dbDistPath
    If Dir(tempPath, vbNormal) <> "" Then Kill tempPath

'Копируем исходную базу по новому пути.... (пока как временную)
    FileCopy dbSoursePath, tempPath

'Зачистка всех таблиц (2 раза - на случай запрета каскадного удаления по связям)
    Set newDB = DBEngine.OpenDatabase(tempPath)
    For i = 1 To 2
    For Each tdf In newDB.TableDefs
        If (tdf.Attributes And dbSystemObject) = False Then
            str = "DELETE FROM [" & tdf.Name & "]"
            newDB.Execute str
        End If
    Next tdf
    Next i

'Сжатие временной базы в файл назначения
    newDB.Close
    DBEngine.CompactDatabase tempPath, dbDistPath
'удаляем временную
    Kill tempPath
    DoEvents

    MsgBox "Пустая БД:" & vbCrLf & dbDistPath & vbCrLf & _
            "Успешно создана.", vbInformation

NewEmptyCloneBye:
    On Error Resume Next
    Set tdf = Nothing
    Set newDB = Nothing
    Exit Sub

NewEmptyCloneErr:
    MsgBox "Процедура [NewEmptyClone] привела к ошибке:" & vbCrLf & _
    Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical
    Resume NewEmptyCloneBye
End Sub
 

Public Function PrepareFolders(strFilePath As String) As Long
'es 20.01.04
'Проверка на наличие и создание папок произвольной вложенности перед
'копированием, перемещением или созданием файла
'--------------------------------------------------------------------
Dim i As Integer
Dim x As Integer
Dim strTemp As String
Dim curPath As String
On Error GoTo PrepareFoldersErr
    x = Len(strFilePath)
    For i = 1 To x
        If Mid(strFilePath, i, 1) = "\" Then
            curPath = Mid(strFilePath, 1, i - 1)
            If Dir(curPath, vbDirectory) = "" Then
                MkDir curPath
            End If
        End If
    Next i
    Exit Function

PrepareFoldersErr:
    PrepareFolders = Err.Number
    Select Case PrepareFolders
        Case 76 'Невеный путь
            MsgBox "Задан не верный путь:" & vbCrLf & _
            strFilePath, vbExclamation, "PrepareFolders"
        Case Else
            MsgBox "Процедура [PrepareFolders] привела к ошибке:" & vbCrLf & _
            Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical
    End Select
    Err.Clear
End Function