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

'##### Создаем новую базу ADO: http://msa.polarcom.ru/st/s0000353.htm

Private Sub test_funCreateDataBaseADO()

blnfunCreateDataBaseADO = funCreateDataBaseADO(True, "D:\Public\Documents\Temp\" & "NewDB.accdb") '"NewDB.mdb"

Set engine = CreateObject("DAO.DBEngine.120")

Set oDbMain = engine.OpenDatabase("D:\Public\Documents\Temp\" & "NewDB.accdb")

End Sub

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

Function funCreateDataBaseADO(ByVal blnReCreate As Boolean, _

ByVal newDB As String) As Boolean

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

'необходимо установить ссылку на библиотеку Microsoft ADO Ext. 2.1 For DDL and Security

Dim cat As ADOX.Catalog ', oDb As Object

Dim m As Variant, strExt As String, strError As String

Err.Clear

On Error GoTo Proc_Err

'считываем расширение файла

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

If Len(newDB) > 0 Then

m = Split(newDB, ".", -1, vbTextCompare)

strExt = m(UBound(m))

Erase m

Else 'выход если файл не задан

strError = "#=================================================" & vbCrLf & _

" " & "funCreateDataBaseADO" & "-" & vbCrLf & _

"Не удалость считать расширение файла" & vbCrLf & "( " & newDB & " )" & vbCrLf & _

"#-------------------------------------------------" & vbCrLf

Resume Proc_Err

End If

'определяем строку подключения в соответствии с форматом создаваемого файла

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

Select Case strExt

Case "mdb": strProvider = "provider=Microsoft.JET.OLEDB.4.0;data source="

Case "accdb": strProvider = "provider=Microsoft.ACE.OLEDB.12.0;Data Source="

Case Else

End Select

'Объект Catalog в ADOx

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

If Dir(newDB) <> "" Then 'Проверка на существование файла

If blnReCreate Then 'Если задано пересоздание

Kill newDB 'Уничтожаем старую базу данных

Else

funCreateDataBaseADO = True

GoTo Proc_Exit 'Выход

End If

End If

Set cat = New ADOX.Catalog

cat.Create (strProvider & newDB) 'Создаем базу

Set cat = Nothing

funCreateDataBaseADO = True

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

Proc_Exit:

Exit Function

Proc_Err:

If Len(strError) = 0 Then

Debug.Print "#=================================================" & vbCrLf & _

" " & "funCreateDataBaseADO" & "-" & vbCrLf & _

Err.Description & vbCrLf & "(" & newDB & ")" & vbCrLf & _

"#-------------------------------------------------"

Else

Debug.Print strError ': MsgBox strError

End If

Resume Proc_Exit

End Function

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

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

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

Sub CreateDataBaseADO(newDB As String)

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

'По материалам книги "Microsoft Access 2000 Development Unleashed" издательства SAMS

'Авторы: Forte, Howe, Ralston

'Объект Catalog в ADOx

Dim cat As ADOx.Catalog

On Error GoTo Proc_Err

Set cat = New ADOx. Catalog

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

MsgBox "Database Created!", vbInformation

Proc_Exit:

Exit Sub

Proc_Err:

MsgBox Err.Description

Resume Proc_Exit

End Sub

Перед использованием ADOx необходимо установить ссылку на библиотеку Microsoft ADO Ext. 2.X For DDL and Security, выполнив команды меню Tools -> References (Сервис -> Ссылки) в VBE.