MyTetra Share
Делитесь знаниями!
Создание(назначение) базы данных
Время создания: 16.03.2019 23:43
Текстовые метки: vba, DAO, CreateWorkspace, Workspace, Готовый модуль
Раздел: !Закладки - VBA - Access - DAO

'#####=====================================================================================================

' Создание(назначение) базы данных

Sub test_CreateDataBaseDAO()

Dim strTblName As String: strTblName = "strTblName"

strPathDb = Range("strPathDb").Value

Set oDb = FnCreateDataBaseDAO(strPathDb)

Таблица = FnIsTablePresent(oDb, strTblName)

If Not Таблица Then Создать_таблицу = FnCreateTblInDB(oDb, strTblName)

End Sub

'

Sub KillDataBase()

On Error Resume Next

Kill "strPath.accdb"

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function FnCreateDataBaseDAO(ByVal strPathDb As String) As DAO.Database

'Dim strPathDb As String

Dim oDb As DAO.Database ' бд, в которой будет создаваться таблица


' strPathDb = Range("strPathDb").Value 'newDB = "strPath.accdb"


If Len(Dir(strPathDb, 16)) = 0 Then 'если база отсутствует

MsgBox "База данных не обнаружена!" & vbCrLf & "Будет создана новая. " & _

vbCrLf & "Посмотрите предыдущие версии и восстановите." & _

vbCrLf & "После восстановления, внесите данные повторно", 48, "Внимание"

Set oDb = DBEngine.Workspaces(0).CreateDatabase(strPathDb, dbLangCyrillic)

' Set oDb = Nothing

Else

End If

Set oDb = OpenDatabase(strPathDb)

Set FnCreateDataBaseDAO = oDb

End Function

'=============================================================================================


'''#####=============================================================================================

'''Создаем новую базу ADO

'''

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''Function FnCreateDataBaseADO(ByVal newDB As String) As Boolean

''''Данная процедура создает новую базу данных с использованием возможностей ADOx.

''''Перед использованием ADOx необходимо установить ссылку на библиотеку _

''Microsoft ADO Ext. 2.1 For DDL and Security, _

''выполнив команды меню Tools | References (Сервис | Ссылки) в VBE.

''''Объект Catalog в ADOx

'' Dim cat As ADOX.Catalog

'' Err.Clear

''' On Error GoTo Proc_Err

'' Set cat = New ADOX.Catalog

'' cat.Create "provider=Microsoft.JET.OLEDB.4.0;data source=" & newDB

''' MsgBox "Database Created!", vblnformation

''

'' If Len(Err.Description) = 0 Then FnCreateDataBaseADO = True

'''Proc_Exit:

'''Exit Function

'''

'''Proc_Err:

''' MsgBox Err.Description

''' Resume Proc_Exit

''End Function

'''=============================================================================================


'================================================================================

'Проверка на наличие таблицы в текущей базе данных

Public Function FnIsTablePresent(ByVal oDb As DAO.Database, _

ByVal strTableName As String) As Boolean

'es - 13.06.2013

'Проверка на наличие таблицы в текущей базе данных

' Если таблица существует - вернет True (Истина = -1)

' В остальных случаях: False

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

Dim i As Integer

On Error Resume Next

'On Error GoTo IsTablePresent_Err


' Пытаемся посчитать кол-во полей в заданной таблице

i = oDb.TableDefs(strTableName).Fields.Count

' Если поля есть - значит и таблица существует (что вполне логично)

If i > 0 Then FnIsTablePresent = True


'IsTablePresent_Bye:

' Exit Function

'

'IsTablePresent_Err:

' 'Болок [Select Case] ниже в принцие не нужен - так ... на всякий случай

' Select Case Err.Number

' Case 3265 ' Ошибка обращения к обьекту (т.е. НЕТ таблицы)

' Case Else

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

' "in procedure IsTablePresent", vbCritical, "Error!"

' End Select

' Resume IsTablePresent_Bye

End Function

'================================================================================


'#####=============================================================================================

'Создаем таблицу в базе

'

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function FnCreateTblInDB(ByVal oDb As DAO.Database, _

ByVal strTblName As String) As Boolean



Dim Tbl As TableDef ' создаваемая таблица

Dim oFld As DAO.Field


On Error Resume Next

Err.Clear


With oDb

Set oTbl = oDb.CreateTableDef(strTblName)

With oTbl

For i = 1 To 15

Select Case i

Case 1: Set oFld = .CreateField("PJI", 10, 12)

Case 2: Set oFld = .CreateField("Clef", 3):

Case 3: Set oFld = .CreateField("Numero_d_enchainement", 3)

Case 4: Set oFld = .CreateField("IdentSkid", 3) ': oFld.AllowZeroLength = True 'пустые строки

Case 5: Set oFld = .CreateField("Зона", 10, 4):

Case 6: Set oFld = .CreateField("Travee", 10, 50) ': oFld.AllowZeroLength = True 'пустые строки

Case 7: Set oFld = .CreateField("Дата_входа", 8)

Case 8: Set oFld = .CreateField("Crit1", 10, 10)

Case 9: Set oFld = .CreateField("Crit2", 10, 10)

Case 10: Set oFld = .CreateField("Crit3", 10, 10)

Case 11: Set oFld = .CreateField("Crit4", 10, 10)

Case 12: Set oFld = .CreateField("Crit5", 10, 10)

Case 13: Set oFld = .CreateField("Crit6", 10, 10)

Case 14: Set oFld = .CreateField("Дата", 8)

Case 15: Set oFld = .CreateField("ДатаPSFV", 8)

End Select

.Fields.Append oFld

Debug.Print i & " - " & Err.Description

Next i

End With

'добавлем таблицу

.TableDefs.Append oTbl

'обновляю данные о таблицах

.TableDefs.Refresh

'создаем ключи по двум полям

.Execute "CREATE UNIQUE INDEX IndexName " _

& "ON Name (PJI,Дата_входа) " _

& "WITH PRIMARY;"

End With

' Set oDb = Nothing

If Len(Err.Description) = 0 Then FnCreateTblInDB = True


End Function

'=============================================================================================

Так же в этом разделе:
 
MyTetra Share v.0.53
Яндекс индекс цитирования