[AccessD] Preparing for upsizing

I am preparing for upsizing a client's access database.  In order to do this
I needed to search all the objects looking for SQL statements and save them
as saved queries.  In order to do this with forms I created the following
two functions:

FindSQL opens each form in the database in design view, then passes the name
of the form and the form's RecordSource off to a function BldSavedQuery.  It
then looks for all controls in the form's control collection looking for
combos and list boxes, and does the same with them.

BldSavedQuery looks for issues like nothing in the SQL statement passed in,
the "QryName" already being the name of a query or table, and if neither of
those conditions exist, then it tries to build a named query def.  If it
succeeds (the SQL passed in is valid and the name passed in is not already a
saved query) it creates a saved query and passes the name back to FindSQL
which then stores the saved query name back in place of the SQL statement.
When all processing is finished, the form is then saved and closed.

It works reasonably well.  The only things found so far are delimited lists
instead of SQL statements and what appear to be saved query names where the
saved query was deleted.  Only about 17 of those, all but one are delimited
lists.  It took me ~ 2 hours to write / debug this code and saved me who
knows how much time manually hunting for these things.

I now have to do the same thing for reports, though there are so few I might
just do them manually.

Function BldSavedQuery(strQryName As String, strSQL As String) As String
On Error GoTo Err_BldSavedQuery
Dim tdf As DAO.TableDef
Dim qdf As DAO.QueryDef
Dim qdfs As DAO.QueryDefs
Dim db As DAO.Database
Dim lstrQryName As String
    
    '
    'This object has nothing in the rowsource/recordsource (probably an
unbound form)
    '
    If strSQL = "" Then
        BldSavedQuery = ""
        GoTo Exit_BldSavedQuery
    End If
    Set db = CurrentDb
    '
    'Check to see if the strsql is the name of a table
    '
    On Error Resume Next
    Set tdf = db.TableDefs(strSQL)
    If Err = 0 Then
        GoTo Exit_BldSavedQuery
    End If
    Err.Clear
    '
    'Check if the strSQL is a query name
    '
    Set qdf = db.QueryDefs(strSQL)
    If Err = 0 Then
        GoTo Exit_BldSavedQuery
    End If
    Err.Clear
On Error GoTo Err_BldSavedQuery
    
    lstrQryName = "q" & strQryName
    Set qdfs = db.QueryDefs
    Set qdf = New QueryDef
    With qdf
        .SQL = strSQL
        .Name = lstrQryName
    End With
    qdfs.Append qdf
    qdfs.Refresh
    BldSavedQuery = qdf.Name
Exit_BldSavedQuery:
On Error Resume Next
    If Not (qdf Is Nothing) Then qdf.Close: Set qdf = Nothing
    Set qdfs = Nothing
    If Not (db Is Nothing) Then db.Close: Set db = Nothing
Exit Function
Err_BldSavedQuery:
    Select Case Err
    Case 3012   'Query already exists
        BldSavedQuery = ""
        Debug.Print "ERROR: " & lstrQryName & " already exists, but this
control has a SQL statement in the rowsource"
        Resume Exit_BldSavedQuery
    Case 3129   'Not an SQL statement - mostly delimited lists or deleted
saved query names
        BldSavedQuery = ""
        Debug.Print "ERROR: " & lstrQryName & " not a sql statement in the
rowsource but not a saved query or table either"
        Debug.Print vbTab & "Rowsource: " & strSQL
        Resume Exit_BldSavedQuery
    Case Else
        MsgBox Err.Description, , "Error in Function
basFindSQL.BldSavedQuery"
        Resume Exit_BldSavedQuery
    End Select
    Resume 0    '.FOR TROUBLESHOOTING
End Function
'
'This module will find all sql statements in objects such as forms, combos
and list boxes
'and save them as saved queries in the name format:
'
'qfrmName
'qfrmname-CboName
'qfrmName-LstName
'
Function FindSQL()
On Error GoTo Err_FindSQL
Dim db As DAO.Database
Dim doc As DAO.Document
Dim frm As Form
Dim ctl As Control
Dim strQryName As String
    Set db = CurrentDb
    For Each doc In db.Containers(2).Documents
        DoCmd.OpenForm doc.Name, acDesign
        Set frm = Forms(doc.Name)
        strQryName = BldSavedQuery(frm.Name, frm.RecordSource)
        If Len(strQryName) > 0 Then
            frm.RecordSource = strQryName
        End If
        For Each ctl In frm.Controls
            Select Case ctl.ControlType
            Case acComboBox, acListBox
                strQryName = BldSavedQuery(frm.Name & "-" & ctl.Name,
ctl.RowSource)
                If Len(strQryName) > 0 Then
                    ctl.RowSource = strQryName
                End If
            Case Else
            End Select
            
        Next ctl
        DoCmd.Close acForm, doc.Name, acSaveYes
    Next doc
Exit_FindSQL:
On Error Resume Next
    If Not (frm Is Nothing) Then frm.Close: Set frm = Nothing
    If Not (db Is Nothing) Then db.Close: Set db = Nothing
Exit Function
Err_FindSQL:
        MsgBox Err.Description, , "Error in Function basFindSQL.FindSQL"
        Resume Exit_FindSQL
    Resume 0    '.FOR TROUBLESHOOTING
End Function

John W. Colby
www.ColbyConsulting.com