Проверьте, существует ли запрос в MS Access из Excel VBA

Question

Следующая функция отлично работает для поиска таблиц в базе данных MS Access через стандартное новое соединение и набор записей **, но она не находит запросы или связанные таблицы.

Function CHKtablename(TABLECHK As String) As Boolean
Dim conn As New Connection
Dim rs As New Recordset
Dim strconn As String
Dim qry As String
Dim chk As Boolean 
strconn = "provider=Microsoft.Ace.Oledb.12.0;" & " Data source= Source path" & "user id=admin;password=" 
conn.Open(strconn) 
Set rs = conn.Openschema(adschematables) 
    While Not rs.EOF
        If rs.Fields("Table_Name") = TABLECHK Then
            CHKtablename = True
        End If
        rs.Movenext
    Wend
End Function

Как я могу изменить это нанайти их?

Я ценю ваше время и помощь.

Answer 1

Было бы неплохо, если бы можно было запросить таблицу MSysObjects, но это ненадежно за пределами Access из-за проблемы с разрешениями.Для меня это не удалось.

Установить ссылку VBA на Microsoft Office x.x Access Database Engine Library.

Один подход использует коллекцию QueryDefs.Проверено и работает для меня.Тем не менее, оба файла находятся на ноутбуке в одной папке пользователя.

Sub CHKqueryname()
Dim db As DAO.Database
Dim qd As DAO.QueryDef
Set db = DBEngine.OpenDatabase("C:\Users\June\LL\Umpires.accdb")
For Each qd In db.QueryDefs
    If qd.Name = "GamesSorted" Then
        Debug.Print qd.Name
        Exit Sub
    End If
Next
End Sub

Если вы хотите избежать QueryDefs, попробуйте код обработчика ошибок:

Sub Chkqueryname()
    On Error GoTo Err:
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Set db = DBEngine.OpenDatabase("C:\Users\June\LL\Umpires.accdb")
    Set rs = db.OpenRecordset("query name")
    rs.MoveLast
    Debug.Print rs.RecordCount
Err:
    If Err.Number = 3078 Then MsgBox "query does not exist"
End Sub

Для версии ADODB установите ссылку на Microsoft ActiveX Data Objects x.x Library.

Sub CHKqueryname()
    On Error GoTo Err:
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source='C:\Users\June\LL\Umpires.accdb'"
    rs.Open "query name", cn, adOpenStatic, adLockReadOnly
    Debug.Print rs.RecordCount
Err:
    If Err.Number = -2147217900 Then MsgBox "query does not exist"
End Sub