Backup and search queries in Microsoft Access

[CZahrobsky]

I use this subroutine a lot to create searchable backups of all of my Access queries. That way, if a table gets refactored, I can update all of my field references through code.

[small][blue]
'************************************************
' subCodeSQL
'************************************************
Sub subCodeSQL()
'** Creates the module "modSQL" containing create scripts for every query in the current db
'** Notes: This code must be in a module to ensure at least one module exists
'** If Modules.Documents(0) is a class module then change MODULE_INDEX
'** Save all modules before running this.
On Error GoTo Err_subCodeSQL
Dim db As Database
Dim docLoop As Document
Dim qdfLoop As QueryDef
Dim intLoop As Integer
Dim strName As String
Dim strBlock As String
Dim strLine As String
Dim strException As String
Dim boolBreakLine As Boolean
Const MODULE_INDEX = 0

Set db = CurrentDb

'--Create initial subroutine framework
strBlock = ""
strBlock = vbCrLf & "sub subRestoreSQL()" & vbCrLf & "Exit_subRestoreSQL:" & vbCrLf & " exit sub" & vbCrLf
strBlock = strBlock & vbCrLf & "Err_subRestoreSQL:" & vbCrLf & " msgbox error$" & vbCrLf
strBlock = strBlock & " resume Exit_subRestoreSQL" & vbCrLf & vbCrLf & "end sub"
strBlock = strBlock & vbCrLf & vbCrLf

'--Create query setup function
strBlock = strBlock & "'*************************************************" & vbCrLf
strBlock = strBlock & "' Print funSetupQuery(" & Chr(34) & "qryTemp" & Chr(34) & ", " & Chr(34)
strBlock = strBlock & "SELECT * FROM tabTemp" & Chr(34) & ")" & vbCrLf
strBlock = strBlock & "'**************************************************" & vbCrLf
strBlock = strBlock & "Function funSetupQuery(strQueryName, strSQL)" & vbCrLf
strBlock = strBlock & "'** Creates a QueryDef from a given query string" & vbCrLf
strBlock = strBlock & "'** Returns the boolean value True if successful" & vbCrLf
strBlock = strBlock & "On Error Resume Next" & vbCrLf
strBlock = strBlock & "Dim db As Database" & vbCrLf
strBlock = strBlock & "Dim qdfLoop As QueryDef" & vbCrLf
strBlock = strBlock & "Dim i As Integer" & vbCrLf & vbCrLf
strBlock = strBlock & " funSetupQuery = False" & vbCrLf & vbCrLf
strBlock = strBlock & " '--Look for existing QueryDefs" & vbCrLf
strBlock = strBlock & " Set db = CurrentDb()" & vbCrLf
strBlock = strBlock & " For i = 0 To db.QueryDefs.Count - 1" & vbCrLf
strBlock = strBlock & " If db.QueryDefs(i).Name = strQueryName Then Exit For" & vbCrLf
strBlock = strBlock & " Next" & vbCrLf & vbCrLf
strBlock = strBlock & " If i >= db.QueryDefs.Count Then" & vbCrLf
strBlock = strBlock & " '--Create new QueryDef from scratch" & vbCrLf
strBlock = strBlock & " Set qdfLoop = db.CreateQueryDef(strQueryName, strSQL)" & vbCrLf
strBlock = strBlock & " If Err = 0 Then funSetupQuery = True" & vbCrLf
strBlock = strBlock & " Else" & vbCrLf
strBlock = strBlock & " '--Change SQL of existing QueryDef" & vbCrLf
strBlock = strBlock & " db.QueryDefs(strQueryName).sql = strSQL" & vbCrLf
strBlock = strBlock & " If Err = 0 Then funSetupQuery = True" & vbCrLf
strBlock = strBlock & " End If" & vbCrLf & vbCrLf
strBlock = strBlock & " Set qdfLoop = Nothing" & vbCrLf
strBlock = strBlock & " Set db = Nothing" & vbCrLf & vbCrLf
strBlock = strBlock & "End Function" & vbCrLf

'--Delete the old module if it exists
On Error Resume Next
For Each docLoop In db.Containers!Modules.Documents
intLoop = intLoop + 1
If docLoop.Name = "modSQL" Then
DoCmd.DeleteObject acModule, "modSQL"
End If
Next docLoop
On Error GoTo Err_subCodeSQL

'--Create a new modSQL by copying the first available module and clearing it
Set docLoop = db.Containers!Modules.Documents(MODULE_INDEX)
DoCmd.CopyObject , "modSQL", acModule, docLoop.Name
DoCmd.OpenModule "modSQL"
DoCmd.Minimize
DoEvents: DoEvents: DoEvents
Modules("modSQL").DeleteLines 1#, Modules("modSQL").CountOfLines - 1

'--Add the SQL creation code
Modules("modSQL").AddFromString strBlock
Modules("modSQL").InsertLines 4#, "On Error Goto Err_subRestoreSQL" '& vbCrLf
Modules("modSQL").InsertLines 5#, "Dim strName as String" '& vbCrLf
Modules("modSQL").InsertLines 6#, "Dim strSQL as String" & vbCrLf
boolBreakLine = False
strBlock = "": strException = Chr(13) & Chr(10) & Chr(34) & ", "
For Each qdfLoop In db.QueryDefs
strBlock = strBlock & " strName = " & Chr(34) & qdfLoop.Name & Chr(34) & vbCrLf
strBlock = strBlock & " strSQL = " & Chr(34) & Chr(34) & vbCrLf
intLoop = 1: strLine = " strSQL = strSQL & " & Chr(34)
Do While intLoop < Len(qdfLoop.SQL & " ")
If InStr(strException, Mid(qdfLoop.SQL, intLoop, 1)) = 0 Then
'--Add a character to the line
strLine = strLine & Mid(qdfLoop.SQL, intLoop, 1)
If Len(strLine) > 90 Then boolBreakLine = True
ElseIf Mid(qdfLoop.SQL, intLoop, 1) = Chr(32) Then
'--Add a new line if current line is too long and a space is found
If boolBreakLine Then
strBlock = strBlock & strLine & Chr(34) & vbCrLf
strLine = " strSQL = strSQL & " & Chr(34) & " "
boolBreakLine = False
Else
strLine = strLine & Mid(qdfLoop.SQL, intLoop, 1)
End If
ElseIf Mid(qdfLoop.SQL, intLoop, 1) = "," Then
'--Add a new line if current line is too long and a comma is found
If boolBreakLine Then
If Right(" " & strLine, 3) = "& " & Chr(34) Then
'--Skip empty quotes
strBlock = strBlock & Mid(strLine, 1, Len(strLine) - 3) & vbCrLf
strLine = " strSQL = strSQL & " & Chr(34) & ","
Else
strBlock = strBlock & strLine & Chr(34) & vbCrLf
strLine = " strSQL = strSQL & " & Chr(34) & ","
End If
boolBreakLine = False
Else
strLine = strLine & Mid(qdfLoop.SQL, intLoop, 1)
End If
ElseIf Mid(qdfLoop.SQL, intLoop, 1) = Chr(13) Then
'--Add a new line if a carriage return is found
If strLine <> " strSQL = strSQL & " & Chr(34) Then
strBlock = strBlock & strLine & " " & Chr(34) & " & vbCrLf" & vbCrLf
strLine = " strSQL = strSQL & " & Chr(34)
End If
boolBreakLine = False
ElseIf Mid(qdfLoop.SQL, intLoop, 1) = Chr(34) Then
'--Add quotes inside the line using the Chr$ function
If boolBreakLine Then
If Right(" " & strLine, 3) = "& " & Chr(34) Then
'--Skip empty quotes
strBlock = strBlock & Mid(strLine, 1, Len(strLine) - 3) & vbCrLf
strLine = " strSQL = strSQL & Chr(34) & " & Chr(34)
Else
strBlock = strBlock & strLine & Chr(34) & vbCrLf
strLine = " strSQL = strSQL & Chr(34) & " & Chr(34)
End If
boolBreakLine = False
Else
strLine = strLine & Chr(34) & " & Chr(34) & " & Chr(34)
If Len(strLine) > 70 Then boolBreakLine = True
End If
End If
intLoop = intLoop + 1
Loop
If strLine <> " strSQL = strSQL & " & Chr(34) Then
strBlock = strBlock & strLine & Chr(34) & vbCrLf
End If
strBlock = strBlock & " Call funSetupQuery(strName, strSQL)" & vbCrLf
If qdfLoop.Connect <> "" Then
strBlock = strBlock & " CurrentDB().QueryDefs(" & Chr(34) & qdfLoop.Name & Chr(34)
strBlock = strBlock & ").Connect = " & Chr(34) & qdfLoop.Connect & Chr(34) & vbCrLf
End If
If qdfLoop.MaxRecords <> 0 Then
strBlock = strBlock & " CurrentDB().QueryDefs(" & Chr(34) & qdfLoop.Name & Chr(34)
strBlock = strBlock & ").MaxRecords = " & qdfLoop.MaxRecords & vbCrLf
End If
If qdfLoop.ODBCTimeout <> 60 Then
strBlock = strBlock & " CurrentDB().QueryDefs(" & Chr(34) & qdfLoop.Name & Chr(34)
strBlock = strBlock & ").ODBCTimeout = " & qdfLoop.ODBCTimeout & vbCrLf
End If
If qdfLoop.Name <> db.QueryDefs(db.QueryDefs.Count - 1).Name Then
strBlock = strBlock & vbCrLf
End If
Debug.Print ".";
Next qdfLoop
Modules("modSQL").InsertLines 8#, strBlock
Modules("modSQL").DeleteLines 1#, 1

'--Label the main function
strBlock = ""
strBlock = strBlock & "'******************************************" & vbCrLf
strBlock = strBlock & "' subRestoreSQL " & vbCrLf
strBlock = strBlock & "'******************************************"
Modules("modSQL").InsertLines 2#, strBlock
strBlock = ""
strBlock = strBlock & "'** Recreates all queries backed up with the command subCodeSQL"
Modules("modSQL").InsertLines 6#, strBlock

'--Close the new module
DoCmd.Close acModule, "modSQL", acSaveYes

On Error GoTo 0
Set db = Nothing
Set docLoop = Nothing

Exit_subCodeSQL:
Exit Sub

Err_subCodeSQL:
MsgBox Error$
Resume Exit_subCodeSQL
Resume

End Sub
[/blue][/small]

 

[Zion7]

That's great CZahrobsky!
Maybe you should consider posting it as a FAQ?