Программное создание базы данных (DAO) - CreateTempDb

Обычное размещение модуль: mod_TempDB

Private Sub CreateTempDb(Optional TempFileName As String = "TempDB.mdb")

'es - 28.09.2012

'--------------------------------------------------------------------

'Создает временную базу данных (MSA-2000-2003) в тек. папке приложения ,

' копирует туда эталонные таблицы и подключает эти таблицы

'ПАРАМЕТРЫ ВЕРСИИ БД:

' dbVersion20 - MSA-2

' dbVersion30 - MSA-97 (compatible with version 3.5).

' dbVersion40 - MSA-2000-2003

' dbVersion120 - MSA-2007-2010

'--------------------------------------------------------------------

Dim TempDBPath As String

Dim db As DAO.Database

Dim strDBaseLink As String

On Error GoTo CreateTempDb_Err

'Получаем путь к создаваемой базе

TempDBPath = CurrentProject.Path & "\" & TempFileName

'Сначала удаляем старую (If present)

If Dir(TempDBPath) <> "" Then

'On Error Resume Next

Kill TempDBPath

DoEvents

Err.Clear

End If

'Создаем базу версии MSA-2000-2003

Set db = DBEngine.CreateDatabase(TempDBPath, dbLangCyrillic, dbVersion40)

db.Close

Set db = Nothing

' Создадим таблицу во временной базе путем копирования эталонной

DoCmd.CopyObject TempDBPath, "tpTempItems", acTable, "atpTempItems"

' Присоединим созданную таблицу к текущей базе

strDBaseLink = ";DATABASE=" & TempDBPath

Call esConnectToTable(strDBaseLink, "tpTempItems")

CurrentDb.TableDefs.Refresh 'Обновляем список таблиц тек. базы (не обязательно)

CreateTempDb_Bye:

On Error Resume Next

db.Close

Set db = Nothing

Exit Sub

CreateTempDb_Err:

MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _

"in procedure CreateTempDb", vbCritical, "Error!"

Resume CreateTempDb_Bye

End Sub

'--------------------------------------------------------------------

' Вспомогательная функция:

'--------------------------------------------------------------------

Public Function esConnectToTable(strBaseLink As String, srsName As String, _

Optional newName As String = "", Optional makeHidden As Boolean = False) As Long

'es - 28.09.2012

'--------------------------------------------------------------------

'Подключение указанной таблицы по аргументам:

' strBaseLink = строка подключения вида: ";DATABASE=C:\DB.mdb"

' srsName = Исходное название таблицы в базе

' makeHidden = Сделать скрытой (по умолч. = нет)

' newName = Новое имя таблицы (по умолч. = srsName)

'При ошибке возвращает ее КОД

'--------------------------------------------------------------------

Dim db As DAO.Database

Dim tdf As DAO.TableDef

'Имя создаваемой таблицы

If newName = "" Then newName = srsName

'Удаление старой (если есть)

On Error Resume Next

Set db = CurrentDb

db.TableDefs.Delete newName

Err.Clear

'Создание и подключение

On Error GoTo ConnectToTableErr

Set tdf = db.CreateTableDef(newName)

tdf.Connect = strBaseLink

tdf.SourceTableName = srsName

db.TableDefs.Append tdf

'Если указано что должна быть скрытая

If makeHidden = True Then tdf.Attributes = dbHiddenObject

ConnectToTableBye:

On Error Resume Next

Set tdf = Nothing

db.Close

Set db = Nothing

Err.Clear

Exit Function

ConnectToTableErr:

esConnectToTable = Err.Number

Debug.Print Err.Description

Resume ConnectToTableBye

End Function