MyTetra Share
Делитесь знаниями!
Создаем новую базу ADO
25.06.2019
12:59
Текстовые метки: http://msa.polarcom.ru/st/s0000353.htm
Раздел: !Закладки - VBA - Access - CreateDataBase

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

'##### Создаем новую базу 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

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

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

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