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

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

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.04

'Создает копию базы данных (с пустыми таблицами) и с поледующим

'обжимом по любому заданному пути - Аргументы:

' 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

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