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

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

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

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