ADOX. Utworzenie w mdb kwerendy parametrycznej i import danych
korzystając z takiej kwerendy
  strona główna:
A po co ten Excel ;-)
 
 
Szmpan się mrozi, wszystko na wieczór gotowe to żeby nie przesiedzieć tych ostatnich paru chwil 2011 roku "nudząc się żywemu Bodu"  
Opiszę jeszcze jedno, ostatnie w tym roku, zadanie.  
     Całość powstała jako element większego projektu, którego założeniem jest że całość będzie utworzona w mdb kodem poprzez ADOX  
i ADO. Czy ten element znajdzie się w tym projekcie? Szczerze to jeszcze nie wiem :-) Ale teraz wydaje mi się że coś analogicznego  
będzie realizować jedno z zadań. Ważna jest zasada że baza i cała jej obsługa będzie stworzona na mdb bez Accessa i choć założenie  
ambitne i nieraz sam nie znam z góry całości rozwiązania udowodnię (przynajmniej sobie) że jest do zrealizowania.  
 
Mamy w test.mdb tabelę tblTemp a w niej przykładowe dane.  
Powiedzmy że często importujemy z tej tabeli dane przez co chcielibyśmy  
stworzyć w samej bazie kwerendę która nam to ułatwi. Chcielibyśmy jednak  
żeby warunki importu danych można było określić w parametrach tej kwerendy.  
 
Stwórzmy więc kwerendę qrySelect w naszej bazie.  
 
(modCreateQry)  
 
Option Explicit  
 
Sub Start()  
    Dim strMDBPath As String: strMDBPath = ThisWorkbook.Path & "\"  
    Const strMDBName As String = "test.mdb"  
    Const strQryName As String = "qrySelect"  
      
    Dim strConnection As String, strSQL As String  
    strConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _  
                    "Jet OLEDB:Engine Type=" & Jet4x & ";" & _  
                    "Data Source=" & strMDBPath & strMDBName  
                      
       'PARAMETERS Declaration (Microsoft Access SQL)   PARAMETERS Declaration
(Microsoft Access SQL)
       'http://msdn.microsoft.com/en-us/library/bb208916(v=office.12).aspx  
         
       'SQL Data Types  
       'http://msdn.microsoft.com/en-us/library/bb208866(v=office.12).aspx   SQL Data Types
         
    strSQL = "PARAMETERS [dData] DATETIME, " & _  
                        "[lSymbol] INTEGER, " & _  
                        "[lKod] INTEGER;" & _  
             "SELECT * " & _  
             "FROM tblTemp " & _  
             "WHERE (((tblTemp.data)=[dData]) " & _  
                "AND ((tblTemp.symbol)=[lSymbol]) " & _  
                "AND ((tblTemp.kod)=[lKod]));"  
                  
    CreateQry strConnection, strQryName, strSQL  
End Sub  
 
(modPublic)  
 
Option Explicit  
 
Public Const adStateOpen = 1  
Public Const adEditNone = 0  
Public Const Jet4x = 5  
Public Const adUseClient = 3  
Public Const adModeRead = 1  
Public Const adCmdStoredProc = 4  
 
Public Const adDate = 7  
Public Const adDouble = 5  
Public Const adParamInput = 1  
 
 
Sub CreateQry(strConnection As String, _  
              strQueryName As String, _  
              strSQL As String)  
                                   
    On Error GoTo CreateQry_Error  
    Dim Catalog As Object 'ADOX.Catalog  
    Dim objCommand As Object 'ADODB.Command  
      
    Set Catalog = CreateObject("ADOX.Catalog") ' New ADOX.Catalog  
    Set objCommand = CreateObject("ADODB.Command") ' New ADODB.Command  
      
    Catalog.ActiveConnection = strConnection  
    Set objCommand.ActiveConnection = Catalog.ActiveConnection  
      
    objCommand.CommandText = strSQL  
    Catalog.Procedures.Append strQueryName, objCommand  
 
CreateQry_Exit:  
    On Error Resume Next  
    CloseConObject Catalog.ActiveConnection  
    Set objCommand = Nothing  
    Exit Sub  
 
CreateQry_Error:  
    MsgBox "Błąd nr - " & Err.Number & vbCrLf & vbCrLf & _  
           Err.Description, vbExclamation, "VBAProject - CreateQry"  
    Resume CreateQry_Exit  
End Sub  
 
Public Sub CloseRSObject(Rs As Object)  
    If Not (Rs Is Nothing) Then  
        With Rs  
            If CBool(.State And adStateOpen) Then  
                If .EditMode <> adEditNone Then .CancelUpdate  
                .Close  
            End If  
        End With  
        Set Rs = Nothing  
    End If  
End Sub  
 
Public Sub CloseConObject(Cnn As Object)  
   If Not (Cnn Is Nothing) Then  
       If Cnn.State = adStateOpen Then Cnn.Close  
       Set Cnn = Nothing  
   End If  
End Sub  
 
Kwerendę zatem tworzymy w mdb poprzez ADOX zapisując jako obiekt ADODB.Command.  
 
"Pikuś" stworzyć kwerendę jak teraz z niej skorzystać? :-)  
 
(modSelectFromQry)  
 
Option Explicit  
 
Sub SelectFromParamQry_ADO()  
    On Error GoTo SelectFromParamQry_ADO_Error  
 
    Dim objConnection As Object 'ADODB.Connection  
    Dim objCommand As Object 'ADODB.Command  
      
    Dim strMDBPath As String: strMDBPath = ThisWorkbook.Path & "\"  
    Const strMDBName As String = "test.mdb"  
 
    Dim strConnStr As String  
    strConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;" & _  
                 "Jet OLEDB:Engine Type=" & Jet4x & ";" & _  
                 "Data Source=" & strMDBPath & strMDBName  
 
    Set objConnection = CreateObject("ADODB.Connection")  
    With objConnection  
        .CursorLocation = adUseClient  
        .Mode = adModeRead  
        .Open strConnStr  
    End With  
 
    Set objCommand = CreateObject("ADODB.Command")  
    With objCommand  
        .ActiveConnection = objConnection  
        .CommandType = adCmdStoredProc  
          
        .CommandText = "qrySelect"  
        .Prepared = True  
        .Parameters.Append .CreateParameter(Name:="dData", _  
                Type:=adDate, _  
                Direction:=adParamInput) _  
                ', Value:=DateSerial(2011, 12, 31))  
        .Parameters.Append .CreateParameter(Name:="lSymbol", _  
                Type:=adDouble, _  
                Direction:=adParamInput) _  
                ', Value:=5031406)  
        .Parameters.Append .CreateParameter(Name:="lKod", _  
                Type:=adDouble, _  
                Direction:=adParamInput) _  
                ', Value:=6054)  
 
        '.Parameters("dData") = DateSerial(2011, 12, 31)  
        '.Parameters("lSymbol") = 5031406  
        '.Parameters("lKod") = 6054  
 
        Dim tblParam(0 To 2) As Variant  
        tblParam(0) = DateSerial(2011, 12, 31)  
        tblParam(1) = 5031406  
        tblParam(2) = 6054  
 
        Dim objRecordset As Object 'ADODB.Recordset  
          
        Set objRecordset = .Execute(Parameters:=tblParam) '.Execute  
        With objRecordset  
            If Not (.BOF And .EOF) Then [A1].CopyFromRecordset objRecordset  
        End With  
 
    End With  
 
SelectFromParamQry_ADO_Exit:  
    On Error Resume Next  
    Set objCommand = Nothing  
    CloseRSObject objRecordset  
    CloseConObject objConnection  
Exit Sub  
 
SelectFromParamQry_ADO_Error:  
    MsgBox "Unexpected error - " & Err.Number & vbCrLf & vbCrLf & _  
            Err.Description, vbExclamation, "VBAProject - SelectFromParamQry"  
    Debug.Print Err.Description  
Resume SelectFromParamQry_ADO_Exit  
   
End Sub   całość do pobrania:
   
Sam nie wiem czy jest sens coś tłumaczyć :-| Powiem tak.. Pisałem całość piewrwszy raz i poszło prawie dobrze za pierwszym razem.   createqry.zip
Potknięcie dotyczyło przekazania do kwerendy parametru daty [dData]. Kombinowałem z formatem amerykańskim :lol: a tu po prostu    
trzeba przekazać datę! :-) Analiza kodu powinna rozwiać resztki niejasności.