TopPicLogo TopPicText

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

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
Назад ToTop
L.E. 15.05.2017
Рейтинг@Mail.ru