ADOX i MDB   strona główna:
A po co ten Excel ;-)
 
Jest to w zasadzie podtórka mojego tematu z excelforum.pl jednak chciałbym mieć go u siebie i tu rozwijać.   ADOX i MDB
excelforum.pl
    Ideą jest wykorzystanie baz danych mdb bez Access'a. Najważniejszą korzyścią związaną z wykorzystaniem bazy danych mdb jest mozliwość  
pracy na Wielkich ilościach danych bez problemów jakich doświadczają Ci którzy takie bazy trzymają w plikcha xls, których nieraz czas w jakim  
taki plik się otwiera przekracza kilka minut, a wyciągnięcie części danych na których chcielibyśmy pracować graniczy z cudem. Jednak taki sposób  
przechowywania danych, a następnie praca na nich musi być przemyślana, a wszelkie środki ostrożności zachowane.   
    W tym artykule zaprezentuję procedury:  
 - tworzacą plik mdb i tabelę na której będziemy pracować. Procedura: CreateMDB  
 - export zakresu danych do wcześniej stworzonej tabeli. Procedura: Excel2MDBADODB  
 - import części danych z mdb do excela. Procedura: MDB2ExcelADODB  
 
Sub CreateMDB()  
    On Error GoTo CreateMDB_Error  
    'ADO reference: Microsoft ADO Ext. 2.X for DDL and Security  
    ' ----------wykorzystano----------  
    'http://www.motobit.com/tips/detpg_createmdb/  
    'http://bytes.com/topic/net/answers/121398-how-do-i-create-mdb-ado-net  
    'http://www.coderscity.net/ftopic8717.html  
    'http://msdn.microsoft.com/en-us/library/aa164917(office.10).aspx  
    ' ----------inne ciekawe----------  
    'http://www.coderscity.net/ftopic3894.html  
      
    Dim Catalog As Object 'New Adox.Catalog  
    Dim tabela As Object 'New ADOX.Table  
    Dim dbIndex As Object 'New ADOX.Index  
    Const adInteger = 3  
    Const adLongVarWChar = 203  
    Const adVarWChar = 202  
      
    Dim strMDBPath As String, strMDBName As String, strTblName As String  
      
    strMDBPath = ThisWorkbook.Path & "\"  
    strMDBName = "test.mdb"  
    strTblName = "TabelaTest1"  
      
    Set Catalog = CreateObject("ADOX.Catalog")  
    Catalog.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _  
                   "Jet OLEDB:Engine Type=" & Jet4x & _  
                   ";Data Source=" & strMDBPath & strMDBName  
      
    Set tabela = CreateObject("ADOX.Table")  
     With tabela  
        .Name = strTblName  
        Set .ParentCatalog = Catalog  
        With .Columns  
            .Append "LP", adInteger                 ' ----Lp jako Klucz Główny---  
            .Append "Nazwa", adVarWChar, 20         'Osoba Prywatna / Firma (wybrać jedno)  
            .Append "Pełna Nazwa", adVarWChar, 50   'Nazwa własna  
            .Append "Imię", adVarWChar, 20          'Imię  
            .Append "Nazwisko", adVarWChar, 50      'Nazwisko  
            .Append "Ulica", adVarWChar, 30         'Ulica  
            .Append "Miasto", adVarWChar, 30        'Miasto  
            .Append "Poczta", adVarWChar, 40        'Kod pocztowy / Poczta  
            .Append "Województwo", adVarWChar, 40   'Województwo  
            .Append "Notes", adLongVarWChar         ' notatka  
        End With  
        With .Columns("LP")  
             Set .ParentCatalog = Catalog  
            .Properties("Autoincrement") = True  
        End With  
        With .Columns("Pełna Nazwa")  
            '(jeśli firma wpisać pełną nazwę – jeśli osoba zostawić puste)  
             Set .ParentCatalog = Catalog  
            .Properties("Jet OLEDB:Allow Zero Length") = True  
        End With  
        With .Columns("Notes")  
             Set .ParentCatalog = Catalog  
            .Properties("Jet OLEDB:Allow Zero Length") = True  
        End With  
    End With  
    Catalog.Tables.Append tabela  
      
    Set dbIndex = CreateObject("ADOX.Index")  
    With dbIndex  
        .Name = "ContactIdx"  
        .PrimaryKey = True  
        .Unique = True  
        .Columns.Append "LP"  
    End With  
    tabela.Indexes.Append dbIndex  
 
CreateMDB_Exit:  
    On Error Resume Next  
    Set dbIndex = Nothing  
    Set tabela = Nothing  
    'http://www.excelforum.pl/topics4/zapis-wartosci-z-formularza-do-bazy-danych-excel-vt8992,15.htm  
    'szuszana >"brak (..) prowadzi do pozostania pliku ldb, co uniemożliwi ponowne otwarcie bazy."<  
    Set Catalog.ActiveConnection = Nothing  
    Set Catalog = Nothing  
    Exit Sub  
 
CreateMDB_Error:  
    MsgBox "Błąd nr - " & Err.Number & vbCrLf & vbCrLf & _  
           Err.Description, vbExclamation, "VBAProject - CreMDB"  
    Resume CreateMDB_Exit  
 
End Sub  
 
Procedura ta utworzy na ścieżce ThisWorkbook.Path & "\" bazę danych mdb, a w niej tabelę TabelaTest1  
 
    strMDBPath = ThisWorkbook.Path & "\"  
    strMDBName = "test.mdb"  
    strTblName = "TabelaTest1"  
      
    Set Catalog = CreateObject("ADOX.Catalog")  
    Catalog.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _  
                   "Jet OLEDB:Engine Type=" & Jet4x & _  
                   ";Data Source=" & strMDBPath & strMDBName  
 
Za utworzenie pliku odpowiada ta część kodu. Następnie tabela:  
 
    Set tabela = CreateObject("ADOX.Table")  
     With tabela  
        .Name = strTblName  
        Set .ParentCatalog = Catalog  
        With .Columns  
            .Append "LP", adInteger                 ' ----Lp jako Klucz Główny---  
            .Append "Nazwa", adVarWChar, 20         'Osoba Prywatna / Firma (wybrać jedno)  
            .Append "Pełna Nazwa", adVarWChar, 50   'Nazwa własna  
            .Append "Imię", adVarWChar, 20          'Imię  
            .Append "Nazwisko", adVarWChar, 50      'Nazwisko  
            .Append "Ulica", adVarWChar, 30         'Ulica  
            .Append "Miasto", adVarWChar, 30        'Miasto  
            .Append "Poczta", adVarWChar, 40        'Kod pocztowy / Poczta  
            .Append "Województwo", adVarWChar, 40   'Województwo  
            .Append "Notes", adLongVarWChar         ' notatka  
        End With  
 
Zgodnie ze składnią Metody Append tworzymy nowe kolumny naszej Tabeli podając: Nazwę kolumny (pola), typ danych i maksymalną ilość znaków   Append Method (ADOX Columns) 
w danym polu. Typ danych określamy poprzez stałe Enumeratora DataTypeEnum.   DataTypeEnum
 
        With .Columns("LP")  
             Set .ParentCatalog = Catalog  
            .Properties("Autoincrement") = True  
        End With  
 
Dla pola Lp określimy właściwość autonumerowania.  
 
        With .Columns("Pełna Nazwa")  
            '(jeśli firma wpisać pełną nazwę – jeśli osoba zostawić puste)  
             Set .ParentCatalog = Catalog  
            .Properties("Jet OLEDB:Allow Zero Length") = True  
        End With  
        With .Columns("Notes")  
             Set .ParentCatalog = Catalog  
            .Properties("Jet OLEDB:Allow Zero Length") = True  
        End With  
 
Pola [Pełna Nazwa] i Notes mogą być puste.  
 
    Set dbIndex = CreateObject("ADOX.Index")  
    With dbIndex  
        .Name = "ContactIdx"   Creating and Modifying Indexes
        .PrimaryKey = True  
        .Unique = True  
        .Columns.Append "LP"  
    End With  
    tabela.Indexes.Append dbIndex  
 
Nadanie polu LP klucza głównego.  
 
Następnie dane z zakresu arkusza wstawimy do naszej tabeli TabelaTest1. Procedura z forum nie działała jednak transakcyjnie. Jednak   
w procedurach exportu danych do bazy danych powinno się zabezpieczyć procedurę pod względem poprawności całego exportu.  
Musimy zapewnić sobie możliwość wycofania wszystkich wprowadzonych do bazy danych w razie jakiegoś nieprzewidzianego błędu.  
 
 
Sub Excel2MDBADODB()  
    On Error GoTo Excel2ACC_Error  
    'ADO reference: Microsoft ActiveX Data Objects 2.8 Library  
    Dim Ark As Excel.Worksheet, r As Long  
    Dim objConnection As Object 'ADODB.Connection  
    Dim objRecordset As Object 'ADODB.Recordset  
    Dim dazaMDB As String, strTblName As String  
    Dim bTrans As Boolean  
      
    dazaMDB = ThisWorkbook.Path & "\test.mdb"  
    strTblName = "TabelaTest1"  
      
    Set objConnection = CreateObject("ADODB.Connection")  
    With objConnection  
        .CursorLocation = adUseClient  
        .Mode = adModeWrite  
        .Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _  
              "Data Source=" & dazaMDB & ";"  
        .BeginTrans: bTrans = True  
    End With  
      
    If IsTabelADODB(objConnection, strTblName) Then  
        Set Ark = ThisWorkbook.Worksheets("Arkusz1")  
 
        Set objRecordset = CreateObject("ADODB.Recordset")  
        objRecordset.Open strTblName, objConnection, adOpenKeyset, adLockOptimistic, adCmdTable  
        r = 2  
        Do While Len(Ark.Range("A" & r)) > 0  
            'If r = 4 Then Err.Raise 10001  
            With objRecordset  
                .AddNew  
                .Fields("Nazwa") = Ark.Range("A" & r).Value  
                .Fields("Pełna Nazwa") = Ark.Range("B" & r).Value  
                .Fields("Pełna Nazwa") = Ark.Range("B" & r).Value  
                .Fields("Imię") = Ark.Range("C" & r).Value  
                .Fields("Nazwisko") = Ark.Range("D" & r).Value  
                .Fields("Ulica") = Ark.Range("E" & r).Value  
                .Fields("Miasto") = Ark.Range("F" & r).Value  
                .Fields("Poczta") = Ark.Range("G" & r).Value  
                .Fields("Województwo") = Ark.Range("H" & r).Value  
                .Update  
            End With  
            r = r + 1  
        Loop  
        If Err.Number = 0 Then MsgBox "Import został zakończony pomyślnie", , "Import zakończony"  
    End If  
 
    objConnection.CommitTrans: bTrans = False  
 
Excel2ACC_Exit:  
    On Error Resume Next  
    Set Ark = Nothing  
    CloseRSObject objRecordset  
    CloseConObject objConnection  
    Exit Sub  
 
Excel2ACC_Error:  
    If bTrans Then  
         objConnection.RollbackTrans  
    End If  
 
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _  
           "Procedura  : " & "Excel2ACC", vbExclamation  
    Resume Excel2ACC_Exit  
End Sub  
 
Pozostaje nam jeszcze przykład procedury Importu danych do komórek Arkusza. W poniższym przykładzie importujemy dane z tabeli TabelaTest1  
pod warunkiem zapisanym w Klauzuli WHERE. Dane z Recordset'u zwracane są do komórek Arkusza metodą CopyFromRecordset obiektu Range.  
 
 
Sub MDB2ExcelADODB()  
    On Error GoTo MDB2ExcelADODB_Error  
    Dim Ark As Excel.Worksheet, r As Long  
    Dim objConnection As Object    'ADODB.Connection  
    Dim objRecordset As Object     'ADODB.Recordset  
    Dim dazaMDB As String, strTblName As String  
    Dim strSQL As String  
 
    Const war1 As String = "Firma"  
    Const war2 As String = "Wojew1"  
 
    dazaMDB = ThisWorkbook.Path & "\test.mdb"  
    strTblName = "TabelaTest1"  
 
    Set objConnection = CreateObject("ADODB.Connection")  
    objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dazaMDB & ";"  
 
    If IsTabelADODB(objConnection, strTblName) Then  
        Set Ark = ThisWorkbook.Worksheets("Arkusz1")  
 
        strSQL = "SELECT Nazwa,[Pełna Nazwa], Imię, Nazwisko, Ulica, Miasto, Poczta, Województwo " & _  
                 "FROM " & strTblName & " " & _  
                 "WHERE Nazwa='" & war1 & "' AND Województwo='" & war2 & "'"  
 
        Set objRecordset = CreateObject("ADODB.Recordset")  
        objRecordset.Open strSQL, objConnection, adOpenKeyset, adLockReadOnly, adCopyOverWrite  
        Ark.Range("A22").CopyFromRecordset objRecordset  
    End If  
 
MDB2ExcelADODB_Exit:  
    On Error Resume Next  
    Set Ark = Nothing  
    CloseRSObject objRecordset  
    CloseConObject objConnection  
    Exit Sub  
 
MDB2ExcelADODB_Error:  
    MsgBox "Błąd Numer - " & Err.Number & vbCrLf & vbCrLf & _  
           Err.Description, vbExclamation, "VBAProject - MDB2ADODB"  
    Resume MDB2ExcelADODB_Exit  
 
End Sub  
 
I to czego brakuje w powyższych procedurach, a więc: stałych, i procedur publicznych.  
 
 
 
Option Explicit  
 
Public Const Jet4x = 5  
Public Const adOpenKeyset = 1  
Public Const adOpenStatic = 3  
Public Const adLockOptimistic = 3  
Public Const adLockReadOnly = 1  
Public Const adCmdTable = 2  
Public Const adCopyOverWrite = 1  
Public Const adStateOpen = 1  
Public Const adEditNone = 0  
 
Public Sub CloseConObject(objConnection As Object)  
    If Not (objConnection Is Nothing) Then  
        If objConnection.State = adStateOpen Then objConnection.Close  
        Set objConnection = Nothing  
    End If  
End Sub  
 
Public Sub CloseRSObject(objRecordset As Object)  
    If Not (objRecordset Is Nothing) Then  
        With objRecordset  
            If CBool(.State And adStateOpen) Then  
                If .EditMode <> adEditNone Then .CancelUpdate  
                .Close  
            End If  
        End With  
        Set objRecordset = Nothing  
    End If  
End Sub  
 
Public Function IsTabelADODB(objConnection As Object, strTblName) As Boolean  
    'na podstawie f. ListaTabelADODB  
    'http://www.excelforum.pl/topics4/import-danych-do-accessa-vt13064.htm  
    On Error GoTo ListaTabelADODB_Error  
    Const adSchemaTables = 20  
    Dim objRecordset As Object 'ADODB.Recordset  
      
    Set objRecordset = CreateObject("ADODB.Recordset")  
    Set objRecordset = objConnection.OpenSchema(adSchemaTables)  
    With objRecordset  
        Do Until .EOF  
            Select Case UCase(.Fields("TABLE_TYPE").Value)  
                Case "TABLE", "LINK"  
                    If .Fields("TABLE_NAME").Value = strTblName Then IsTabelADODB = True: Exit Do  
            End Select  
            .MoveNext  
        Loop  
    End With  
      
ListaTabelADODB_Exit:  
    On Error Resume Next  
    Call CloseRSObject(objRecordset)    
    Exit Function   Przykład można pobrac z:
  createmdb.zip
ListaTabelADODB_Error:  
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _  
           "Procedura  : " & "ListaTabelADODB", vbExclamation    
    Resume ListaTabelADODB_Exit  
End Function