Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - uruchamianie kwerendy w bazie Access z makra w Excel

golly · Exceloholic Posty: 360

Witajcie,

Jaką komendą uruchamia się kwerendę w Access (2003) z poziomu makra w Excelu (2003)?
dla przykładu:

ścieżka do katalogu z plikiem bazy: C:\BAZA
nazwa pliku bazy: MagazynBaza.mdb
nazwa kwerendy: qrySprzedaz2 (jeśli to istotne to u mnie jest to Kwerenda tworząca tabele)

Nie wiem czy nie trzeba wyłączyć dodatkowo jakiś zabezpieczeń i pytań w Access bo jak robię to ręcznie (screeny w załączniku)

Pozdrawiam
golly

Schowek-3.jpg

Plik ściągnięto 8 raz(y) 17.54 KB

Schowek-2.jpg

Plik ściągnięto 9 raz(y) 17.1 KB

Schowek-1.jpg

Plik ściągnięto 8 raz(y) 23.39 KB

tkuchta1 · Excel Expert **Pomógł:** 1495 razy Posty: 2270

a tak

Kod:

Option Explicit
Const adStateOpen = 1
Const adEditNone = 0

Sub kwerenda()
On Error GoTo kwerenda_Error

Const adCmdText = 1
Const adCmdStoredProc = 4

Dim objConnection As Object 'ADODB.Connection
Dim strMdbFilePath As String
strMdbFilePath = ThisWorkbook.Path & "\db1.mdb"

Set objConnection = CreateObject("ADODB.Connection")

With objConnection
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0"
.Open strMdbFilePath
End With

If IsTabelADODB(objConnection, "tblTestNew") Then
ExecuteNoRecords_ADO objConnection, "DROP TABLE [tblTestNew];", adCmdText
End If

ExecuteNoRecords_ADO objConnection, "qryTest", adCmdStoredProc

kwerenda_Exit:
On Error Resume Next
CloseConObject objConnection
Exit Sub

kwerenda_Error:
MsgBox "Unexpected error - " & Err.Number & vbCrLf & vbCrLf & _
Err.Description, vbExclamation, "VBAProject - Kwe"
Resume kwerenda_Exit

End Sub

Sub ExecuteNoRecords_ADO(objConnection As Object, _
strQuery As String, _
cmdTCommandType As Variant)

On Error GoTo ExecuteNoRecords_Error
Dim objCommand As Object

Const adExecuteNoRecords = 128

Set objCommand = CreateObject("ADODB.Command")

With objCommand
.ActiveConnection = objConnection
.CommandType = cmdTCommandType
.CommandText = strQuery
.Execute Options:=adExecuteNoRecords
End With

ExecuteNoRecords_Exit:
On Error Resume Next
Set objCommand = Nothing
Exit Sub

ExecuteNoRecords_Error:
MsgBox "Błąd Numer - " & Err.Number & vbCrLf & vbCrLf & _
Err.Description, vbExclamation, "VBAProject - ExecuteNoRecords"
Resume ExecuteNoRecords_Exit
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

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 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

ListaTabelADODB_Error:
MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
"Procedura : " & "ListaTabelADODB", vbExclamation
Resume ListaTabelADODB_Exit
End Function

------------- edit: 2011-12-16 12:56 --------------
Zapomniałem przerobić na późne wiązanie.. Podnieniam załącznik

Pulpit.zip

Pobierz Plik ściągnięto 9 raz(y) 18.21 KB

golly · Exceloholic Posty: 360

Wieeeelkie dzięki.

Muszę się oczywiście ogarnąć w tym makrze ale znając Ciebie wszystko będzie grało jak należy.

Bardzo dziękuję. Brak mi słów wdzięczności.

pozdrawiam serdecznie
golly