Hi J,
not exactly what you asked for, but hopefully you can see the logic and
pull what you need
'~~~~~~~~~~~~~
Sub DocModules( _
ByVal pPath As String _
)
'crystal
'strive4peace2006 at yahoo dot com
'CALLS
'DocProcs
'TABLES
'DocDbs
'DocMods
'DocModProcs
'REPORT
'rpt_DocProcs
'---------- Initialize
On Error GoTo Proc_Err
'---------- Dimension Variables
Dim accApp As Access.Application _
, dbCur As Database _
, rDb As DAO.Recordset _
, rMod As DAO.Recordset _
, rProc As DAO.Recordset
Dim mStartTime As Date _
, mMsg As String
Dim mdl As Module _
, iMod As Integer _
, iProc As Integer _
, S As String _
, mNumDbs As Integer _
, mNumMods As Integer _
, mNumProcs As Integer
Dim mFilename As String _
, mFileSpec As String _
, iNumFiles As Integer
Dim arrProcNames() As String _
, ModID_first As Long
Dim mDbID As Long _
, mModID As Long
'---------- Assign Variables
mStartTime = Now
mNumMods = 0
mNumProcs = 0
If Len(Trim(Nz(pPath, ""))) = 0 Then
pPath = CurrentProject.Path
End If
If Right(pPath, 1) <> "\" Then pPath = pPath & "\"
Set accApp = CreateObject("Access.Application")
Set dbCur = CurrentDb
Set rDb = dbCur.OpenRecordset("docDbs", dbOpenDynaset)
Set rMod = dbCur.OpenRecordset("docMods", dbOpenDynaset)
Set rProc = dbCur.OpenRecordset("docModProcs", dbOpenDynaset)
mFileSpec = pPath & "*.mdb"
mFilename = Dir(mFileSpec)
Do While Not Len(Trim(Nz(mFilename, ""))) = 0
accApp.OpenCurrentDatabase _
(pPath & mFilename)
rDb.AddNew
rDb!dbname = mFilename
rDb!dbpath = pPath
mDbID = rDb!DbID
rDb.Update
mNumDbs = mNumDbs + 1
ModID_first = 0
For iMod = 0 To accApp.Modules.Count - 1
With accApp.Modules(iMod)
Debug.Print "-- " & .Name
rMod.AddNew
rMod!DbID = mDbID
rMod!ModName = .Name
rMod!NumLines = .CountOfLines
rMod!NumLinesDecl = .CountOfDeclarationLines
mModID = rMod!ModID
rMod.Update
mNumMods = mNumMods + 1
If Left(.Name, 5) = "form_" Or Left(.Name, 7) = "report_" Then
GoTo nextModule
End If
MsgBox .Name, , ".Name"
DocProcs accApp, .Name, arrProcNames, False
End With
If ModID_first = 0 Then ModID_first = mModID
With accApp.Modules(iMod)
For iProc = LBound(arrProcNames) To UBound(arrProcNames)
Debug.Print "* " & arrProcNames(iProc)
rProc.AddNew
rProc!ModID = mModID
rProc!StartLine = Nz(.ProcStartLine(arrProcNames(iProc),
0), 0)
rProc!BodyLine = Nz(.ProcBodyLine(arrProcNames(iProc),
0), 0)
rProc!CountLines =
Nz(.ProcCountLines(arrProcNames(iProc), 0), 0)
rProc!procName = arrProcNames(iProc)
rProc.Update
mNumProcs = mNumProcs + 1
Next iProc
End With
nextModule:
Next iMod
mFilename = Dir()
Loop
mMsg = mNumProcs & " Procedures" _
& vbCrLf & " in" _
& vbCrLf & mNumMods & " Modules" _
& vbCrLf & " in" _
& vbCrLf & mNumDbs & " Databases" _
& vbCrLf & vbCrLf
mMsg = mMsg & "Start Time: " & Format(mStartTime, "hh:nn:ss") & vbCrLf _
& "End Time: " & Format(Now(), "hh:nn:ss") & " --> " _
& " Elapsed Time: " & Format((Now() - mStartTime) * 24 * 60 *
60, "0.####") & " seconds"
MsgBox mMsg, , "Done documenting modules"
DoCmd.OpenReport "rpt_DocProcs", acViewPreview, , "ModID >=" &
ModID_first
Proc_Exit:
On Error Resume Next
'close and release object variables
Set mdl = Nothing
rProc.Close
Set rProc = Nothing
rMod.Close
Set rMod = Nothing
rDb.Close
Set rDb = Nothing
accApp.Quit
Set accApp = Nothing
Set dbCur = Nothing
Exit Sub
Proc_Err:
MsgBox Err.Description, , _
"ERROR " & Err.Number & " DocModules"
'press F8 to step through code and debug
'remove next line after debugged
Stop: Resume
Resume Proc_Exit
End Sub
'~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'changed from MS Help:
Public Function DocProcs( _
pApp As Access.Application _
, ByVal pModuleName As String _
, ByRef parrProcNames _
, Optional SayMsg = True _
)
On Error GoTo Proc_Err
Dim mdl As Module
Dim lngCount As Long
Dim lngCountDecl As Long
Dim lngI As Long
Dim strProcName As String
' Dim parrProcNames() As String
Dim intI As Integer
Dim strMsg As String
Dim lngR As Long
' Open specified Module object.
pApp.DoCmd.OpenModule pModuleName
' Return reference to Module object.
Set mdl = pApp.Modules(pModuleName)
' Count lines in module.
lngCount = mdl.CountOfLines
' Count lines in Declaration section in module.
lngCountDecl = mdl.CountOfDeclarationLines
' Determine name of first procedure.
strProcName = mdl.ProcOfLine(lngCountDecl + 1, lngR)
' Initialize counter variable.
intI = 0
' Redimension array.
ReDim Preserve parrProcNames(intI)
' Store name of first procedure in array.
parrProcNames(intI) = 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
' Increment counter.
intI = intI + 1
strProcName = mdl.ProcOfLine(lngI, lngR)
ReDim Preserve parrProcNames(intI)
' Assign unique procedure names to array.
parrProcNames(intI) = strProcName
End If
Next lngI
strMsg = "Procedures in module '" & pModuleName & "': " & vbCrLf &
vbCrLf
For intI = 0 To UBound(parrProcNames)
strMsg = strMsg & parrProcNames(intI) & vbCrLf
Next intI
' Message box listing all procedures in module.
If SayMsg Then MsgBox strMsg
Proc_Exit:
On Error Resume Next
Exit Function
Proc_Err:
MsgBox Err.Description, , _
"ERROR " & Err.Number & " DocProcs"
'press F8 to step through code and debug
'remove next line after debugged
Stop: Resume
Resume Proc_Exit
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Warm Regards,
Crystal
*
have an awesome day
*
MVP Access
Remote Programming and Training
strive4peace2006 at yahoo.com
*
