Trying to find out which queries in your Microsoft Access database are pass-through queries, which ones have parameters, or which ones have crosstab headings specified? This VBA function sends the values of 42 different query properties and attributes to a table. It works for a specific query, or for all of the queries in the database.
Before using the function, you will need to build the QueryProperties table, which is defined in the code below. At the end of the function logic, it automatically opens the table to show you the results.
Call the function in the Immediate window like this:
?SendQueryPropertyValuesToATable
' Build the QueryProperties table:
' FIELD NAME FIELD TYPE
' ======================= ============
' QueryPropertiesID AutoNumber
' CacheSize Long Integer
' ColumnHeadings Long Text
' Connect Long Text
' DateCreated Date/Time
' DefaultView Short Text
' Description Long Text
' DestConnectStr Long Text
' DestinationDB Long Text
' Destinationtable Short Text
' FailOnError Yes/No
' Filter Long Text
' FilterOnLoad Yes/No
' FrozenColumns Integer
' LastUpdated Date/Time
' LinkChildFields Long Text
' LinkMasterFields Long Text
' LogMessages Yes/No
' MaxRecords Long Integer
' NameOfQuery Short Text
' ODBCTimeout Integer
' OrderBy Long Text
' OrderByOn Yes/No
' OrderByOnLoad Yes/No
' Orientation Short Text
' OutputAllFields Yes/No
' Parameters Yes/No
' Prepare Short Text
' RecordLocks Short Text
' RecordsAffected Long Integer
' RecordsetType Short Text
' ReturnsRecords Yes/No
' SQL Long Text
' SubdatasheetExpanded Yes/No
' SubdatasheetHeight Integer
' SubdatasheetName Short Text
' TopValues Yes/No
' TotalsRow Yes/No
' Type Short Text
' UniqueRecords Yes/No
' UniqueValues Yes/No
' Updatable Yes/No
' UseTransaction Yes/No
' QueryPropertiesProcessed Yes/No
'
' Long Integer, Integer - set Default Value = blank
' Short Text - set Field Size = 255
'
Public Function SendQueryPropertyValuesToATable(Optional QueryName As String) As Boolean
' This function fills the QueryProperties table with query properties and
' attributes.
'
' AsciiCodeList() Version 1.0.0
' Copyright © 2023 Extra Mile Data, www.extramiledata.com.
' For questions or issues, please contact [email protected].
' Use (at your own risk) and modify freely as long as proper credit is given.
'
On Error GoTo Err_Handler
Dim db As DAO.Database
Dim tbl As DAO.TableDef
Dim fld As DAO.Field
Dim astrFields() As String
Dim intElem As Integer
Dim strSQL As String
Dim qdf As DAO.QueryDef
Dim rst As DAO.Recordset
Dim strField As String
Dim varValue
Dim lngCount As Long
Dim lngTotalCount As Long
Dim strQuerySQL As String
Dim lngPos As Long
Dim lngPosEnd As Long
' Close the QueryProperties table if it is open.
If CurrentData.AllTables("QueryProperties").IsLoaded Then
DoCmd.Close acTable, "QueryProperties", acSaveNo
End If
Set db = CurrentDb
strSQL = "DELETE * FROM QueryProperties"
db.Execute strSQL, dbFailOnError
Set tbl = db.TableDefs("QueryProperties")
ReDim astrFields(tbl.Fields.Count - 1)
intElem = 0
For Each fld In tbl.Fields
astrFields(intElem) = fld.Name
intElem = intElem + 1
Next fld
strSQL = "SELECT * FROM QueryProperties"
Set rst = db.OpenRecordset(strSQL)
If QueryName = "" Then
For Each qdf In db.QueryDefs
If Left(qdf.Name, 4) <> "~sq_" Then
rst.AddNew
rst!NameOfQuery = qdf.Name
rst.Update
End If
Next qdf
Else
rst.AddNew
rst!NameOfQuery = QueryName
rst.Update
End If
lngCount = 0
With rst
.MoveLast
lngTotalCount = .RecordCount
.MoveFirst
Do Until .EOF
.Edit
Set qdf = db.QueryDefs(!NameOfQuery)
For intElem = 0 To UBound(astrFields)
strField = astrFields(intElem)
Select Case strField
Case "QueryPropertiesID", "QueryPropertiesProcessed", "NameOfQuery"
' Ignore.
Case "ColumnHeadings"
If qdf.Type = 16 Then
strQuerySQL = qdf.SQL
lngPos = InStr(1, strQuerySQL, "PIVOT")
If lngPos > 0 Then
lngPos = InStr(lngPos + 5, strQuerySQL, " In (")
If lngPos > 0 Then
lngPos = lngPos + 5
lngPosEnd = InStr(lngPos, strQuerySQL, ")")
If lngPosEnd > 0 Then
.Fields(strField) = Trim(Mid(strQuerySQL, lngPos, _
(lngPosEnd - 1) - lngPos))
End If
End If
End If
End If
Case "DefaultView"
On Error Resume Next
varValue = qdf.Properties(strField).Value
If Err = 0 Then
Select Case varValue
Case 0
.Fields(strField) = "Single Form"
Case 1
.Fields(strField) = "Continuous Form"
Case 2
.Fields(strField) = "Datasheet"
Case 3
.Fields(strField) = "PivotTable"
Case 4
.Fields(strField) = "PivotChart"
Case 5
.Fields(strField) = "Split Form"
End Select
Else
Err = 0
End If
On Error GoTo Err_Handler
Case "DestConnectStr"
' Not sure what the best way to do this is.
Case "DestinationDB"
' Just look for ODBC or for ACCDB.
strQuerySQL = qdf.SQL
varValue = Null
If InStr(1, strQuerySQL, "ODBC") > 0 Then
varValue = "ODBC"
ElseIf InStr(1, strQuerySQL, "ACCDB") > 0 Then
varValue = "ACCDB"
End If
.Fields(strField) = varValue
Case "DestinationTable"
' INSERT INTO tablename (
strQuerySQL = qdf.SQL
lngPos = InStr(1, strQuerySQL, "INSERT INTO ")
If lngPos > 0 Then
lngPos = lngPos + 11
lngPosEnd = InStr(lngPos, strQuerySQL, "(")
If lngPosEnd > 0 Then
.Fields(strField) = Trim(Mid(strQuerySQL, lngPos, _
(lngPosEnd - 1) - lngPos))
End If
End If
Case "Orientation"
On Error Resume Next
varValue = qdf.Properties(strField).Value
If Err = 0 Then
Select Case varValue
Case 0
.Fields(strField) = "Left-to-right"
Case 1
.Fields(strField) = "Right-to-left"
End Select
Else
Err = 0
End If
On Error GoTo Err_Handler
Case "OutputAllFields"
strQuerySQL = qdf.SQL
If InStr(1, strQuerySQL, ", *") > 0 _
Or InStr(1, strQuerySQL, " *") > 0 Then
.Fields(strField) = True
Else
.Fields(strField) = False
End If
Case "Parameters"
strQuerySQL = qdf.SQL
If InStr(1, strQuerySQL, "PARAMETERS ") > 0 Then
.Fields(strField) = True
Else
.Fields(strField) = False
End If
Case "Prepare"
On Error Resume Next
varValue = qdf.Properties(strField).Value
If Err = 0 Then
Select Case varValue
Case 1
.Fields(strField) = "Prepare"
Case 2
.Fields(strField) = "UnPrepare"
End Select
Else
Err = 0
End If
On Error GoTo Err_Handler
Case "RecordLocks"
On Error Resume Next
varValue = qdf.Properties(strField).Value
If Err = 0 Then
Select Case varValue
Case 0
.Fields(strField) = "No Locks"
Case 1
.Fields(strField) = "All Records"
Case 2
.Fields(strField) = "Edited Record"
End Select
Else
Err = 0
End If
On Error GoTo Err_Handler
Case "RecordsetType"
On Error Resume Next
varValue = qdf.Properties(strField).Value
If Err = 0 Then
Select Case varValue
Case 0
.Fields(strField) = "Dynaset"
Case 1
.Fields(strField) = "Dynaset (Inconsistent Updates)"
Case 2
.Fields(strField) = "Snapshot"
End Select
Else
Err = 0
End If
On Error GoTo Err_Handler
Case "TopValues"
strQuerySQL = qdf.SQL
If InStr(1, strQuerySQL, " TOP ") > 0 Then
.Fields(strField) = True
Else
.Fields(strField) = False
End If
Case "Type"
On Error Resume Next
varValue = qdf.Properties(strField).Value
If Err = 0 Then
Select Case varValue
Case 240
.Fields(strField) = "Action"
Case 64
.Fields(strField) = "Append"
Case 160
.Fields(strField) = "Compound"
Case 16
.Fields(strField) = "Crosstab"
Case 96
.Fields(strField) = "Data-definition"
Case 32
.Fields(strField) = "Delete"
Case 80
.Fields(strField) = "Make-table"
Case 224
.Fields(strField) = "Procedure"
Case 0
.Fields(strField) = "Select"
Case 128
.Fields(strField) = "Union"
Case 144
.Fields(strField) = "Bulk pass-through"
Case 112
.Fields(strField) = "Pass-through"
Case 48
.Fields(strField) = "Update"
End Select
Else
Err = 0
End If
On Error GoTo Err_Handler
Case "UniqueRecords"
strQuerySQL = qdf.SQL
If InStr(1, strQuerySQL, "DISTINCTROW ") > 0 Then
.Fields(strField) = True
Else
.Fields(strField) = False
End If
Case "UniqueValues"
strQuerySQL = qdf.SQL
If InStr(1, strQuerySQL, "DISTINCT ") > 0 Then
.Fields(strField) = True
Else
.Fields(strField) = False
End If
Case Else
On Error Resume Next
varValue = qdf.Properties(strField).Value
If Err = 0 Then
.Fields(strField) = varValue
Else
Err = 0
End If
On Error GoTo Err_Handler
End Select
Next intElem
!QueryPropertiesProcessed = True
.Update
lngCount = lngCount + 1
If lngCount Mod 25 = 0 Then
Debug.Print lngCount & " of " & lngTotalCount
DoEvents
End If
.MoveNext
Loop
End With
' Open the QueryProperties table.
DoCmd.OpenTable "QueryProperties"
SendQueryPropertyValuesToATable = True
Exit_Proc:
On Error Resume Next
Set fld = Nothing
Set tbl = Nothing
Set qdf = Nothing
Set db = Nothing
Exit Function
Err_Handler:
MsgBox Err.Number & " " & Err.Description, vbCritical, "SendQueryPropertyValuesToATable()"
SendQueryPropertyValuesToATable = False
Resume Exit_Proc
Resume
End Function
Making Microsoft Access Work. Call (505) 369-1650.