I'm going through my database cleaning it up and adding error trapping and
needed something similar. Trawling the forum I found a couple of suggestions
which I've combined as below. Copy it to a new module then compile and save
it. I run it from the immediate window of the VBA editor as a user will
never need it. I've tried it on A2003 and A2007 and it works OK. No doubt it
could be improved, as it does leave all the VBA modules open in the VBA
editor, but it filled a need, and anyway it's entertaining to watch! I take
NO credit for the code - I just fiddled with it. Credit is due to DC Conlin
and the great Allen Browne.
Cheers,
Bob
(beware of some word-wrapping)
====start of code=====
Function fexportModules(sDestPath As String, Optional sList As Boolean =
True) As Boolean
' this function from an original idea by D C Conlin
' this will output listing of ALL procedures in all modules, forms, and
reports.
' if sList set true (default) will output list of modules to text file
'Module_Listing.txt',
' which can then be printed.
' if sList set false will backup all modules to files *.bas in destination
set by sDestPath
' NOTE: this opens every object and closes them except for standard modules
which remain
' open in VBA editor window.
On Error GoTo ErrHandler
Dim recSet As DAO.Recordset
Dim frm As Form
Dim rpt As Report
Dim sqlStmt As String
Dim sObjName As String
Dim idx As Long
Dim fOpenedRecSet As Boolean
Dim ModFile As String
'--------------------------------------------------------------
' Ensure that there's a backslash at the end of the path.
'--------------------------------------------------------------
If (Mid$(sDestPath, Len(sDestPath), 1) <> "\") Then
sDestPath = sDestPath & "\"
End If
'--------------------------------------------------------------
' Export standard modules and classes.
'--------------------------------------------------------------
ModFile = sDestPath & "Module_Listing.txt"
' if the file exists, delete it.
If sList = True And FileExists(ModFile) Then Kill ModFile
' now open file for output
If sList = True Then
Open ModFile For Output As #1
' output date and time to file at start
Print #1, Now() & vbCrLf
End If
STANDARD:
sqlStmt = "SELECT [Name] " & _
"FROM MSysObjects " & _
"WHERE ([Type] = -32761);"
Set recSet = CurrentDb().OpenRecordset(sqlStmt)
fOpenedRecSet = True
If (Not (recSet.BOF And recSet.EOF)) Then
recSet.MoveLast
recSet.MoveFirst
For idx = 1 To recSet.RecordCount
If sList = True Then
Print #1, vbCrLf & "STANDARD MODULE"
Print #1, recSet.Fields(0).Value
Print #1, "========================================="
' Debug.Print vbCrLf
' Debug.Print recSet.Fields(0).Value
' Debug.Print "========================================="
fListProc recSet.Fields(0).Value
Else
' backup to .bas file
SaveAsText acModule, recSet.Fields(0).Value, sDestPath &
recSet.Fields(0).Value & ".bas"
End If
If (Not (recSet.EOF)) Then
recSet.MoveNext
End If
Next idx
End If
'--------------------------------------------------------------
' Export form modules.
'--------------------------------------------------------------
FORMS:
sqlStmt = "SELECT [Name] " & _
"FROM MSysObjects " & _
"WHERE ([Type] = -32768);"
Set recSet = CurrentDb().OpenRecordset(sqlStmt)
fOpenedRecSet = True
If (Not (recSet.BOF And recSet.EOF)) Then
recSet.MoveLast
recSet.MoveFirst
For idx = 1 To recSet.RecordCount
sObjName = recSet.Fields(0).Value
DoCmd.OpenForm sObjName, acDesign
Set frm = FORMS(sObjName)
If (frm.HasModule) Then
If sList = True Then
Print #1, vbCrLf & "FORM MODULE"
Print #1, frm.Module
Print #1, "========================================="
' Debug.Print vbCrLf
' Debug.Print frm.Module
' Debug.Print "========================================="
fListProc frm.Module
Else
' backup to .bas file
DoCmd.OutputTo acOutputModule, "Form_" & sObjName,
acFormatTXT, sDestPath & sObjName & ".bas"
End If
End If
DoCmd.Close acForm, sObjName
If (Not (recSet.EOF)) Then
recSet.MoveNext
End If
Next idx
End If
'--------------------------------------------------------------
' Export report modules.
'--------------------------------------------------------------
REPORTS:
sqlStmt = "SELECT [Name] " & _
"FROM MSysObjects " & _
"WHERE ([Type] = -32764);"
Set recSet = CurrentDb().OpenRecordset(sqlStmt)
fOpenedRecSet = True
If (Not (recSet.BOF And recSet.EOF)) Then
recSet.MoveLast
recSet.MoveFirst
For idx = 1 To recSet.RecordCount
sObjName = recSet.Fields(0).Value
DoCmd.OpenReport sObjName, acDesign
Set rpt = REPORTS(sObjName)
If (rpt.HasModule) Then
If sList = True Then
sObjName = recSet.Fields(0).Value
Print #1, vbCrLf & "REPORT MODULE"
Print #1, rpt.Module
Print #1, "========================================="
' Debug.Print vbCrLf
' Debug.Print rpt.Module
' Debug.Print "========================================="
fListProc rpt.Module
Else
' backup to .bas file
DoCmd.OutputTo acOutputModule, "Report_" & sObjName,
acFormatTXT, sDestPath & sObjName & ".bas"
End If
End If
DoCmd.Close acReport, sObjName
If (Not (recSet.EOF)) Then
recSet.MoveNext
End If
Next idx
End If
fexportModules = True ' Success.
If sList = True Then
MsgBox "All modules listed in " & vbCrLf & ModFile
Else
MsgBox "All VBA backed up to " & vbCrLf & sDestPath
End If
CleanUp:
If (fOpenedRecSet) Then
recSet.Close
fOpenedRecSet = False
End If
Close #1
Set frm = Nothing
Set rpt = Nothing
Set recSet = Nothing
Exit Function
ErrHandler:
MsgBox "Error in fexportModules( )." & vbCrLf & vbCrLf & _
"Error #" & Err.number & vbCrLf & vbCrLf & Err.Description
Err.Clear
fexportModules = False ' Failed.
GoTo CleanUp
End Function ' fexportModules( )
Function fListProc(strModuleName As String) As String
' this function lists the procedures in a module passed as strModuleName
' this function from an original idea by Allen Browne
On Error GoTo Err_fListProc
Dim mdl As Module
Dim lngCount As Long
Dim lngCountDecl As Long
Dim lngI As Long
Dim strProcName As String
Dim intI As Integer
Dim strMsg As String
Dim lngR As Long
' Open specified Module object.
DoCmd.OpenModule strModuleName
Set mdl = Modules(strModuleName)
lngCount = mdl.CountOfLines
lngCountDecl = mdl.CountOfDeclarationLines
' Determine name of first procedure.
strProcName = mdl.ProcOfLine(lngCountDecl + 1&, lngR)
intI = 0
'Debug.Print strProcName, lngR
'Debug.Print strProcName
Print #1, strProcName
' Determine procedure name for each line after declarations.
For lngI = lngCountDecl + 1& To lngCount
' Compare procedure name with ProcOfLine property value.
If strProcName <> mdl.ProcOfLine(lngI, lngR) Then
intI = intI + 1&
strProcName = mdl.ProcOfLine(lngI, lngR)
Print #1, strProcName
'Debug.Print strProcName
' Debug.Print , "ProcStartLine = " &
mdl.ProcStartLine(strProcName, lngR)
' Debug.Print , "ProcBodyLine " & mdl.ProcBodyLine(strProcName,
lngR)
' ProcBodyLine is the declaration; ProcStartLine is the
blankspace above procedure.
End If
Next lngI
Exit_fListProc:
Exit Function
Err_fListProc:
MsgBox "Error in fexportModules( )." & vbCrLf & vbCrLf & _
"Error #" & Err.number & vbCrLf & vbCrLf & Err.Description
Err.Clear
GoTo Exit_fListProc
End Function
=====end of code=====
