Mark A Matte
markamatte at hotmail.com
Tue Apr 8 09:31:43 CDT 2008
Roz,
I found this online when I started my project. I have NOT used it yet...but it seems to be related to yours.
Also, this code stores the data in a table...so for your future wishes...you could display the original and your changes.
Good luck,
Mark A. Matte
'********* Code Starts Here ********
Option Compare Database
Option Explicit
Public Function EnumerateModules(strPath As String, strPassWord As String, Optional bolEmptytable As Boolean = True) As Boolean
'------------------------------------------------------------------------------
'Purpose: Go through all of the Modules in the specified database and put them
' into a table, creating the table if it does not exist.
'Parameters:
' strDatabasePath: The full path of the database you wish to enumerate;
' "" if you want the current database
'Sets: Puts all information into the table 'tblModules'. If it is not there,
' create the table
'Returns: Boolean value telling if it finished correctly, or there was an error.
'Author: Stan Paszt
'Created: 08/10/2001
'Modified:
'------------------------------------------------------------------------------
'Changes by Gary Walter 10/3/2001
'1) Added automation to always open another instance of "OtherDB."
'2) Expects full path to OtherDB even if same db as this one.
'3) Changed some fields in tblModules where info from OtherDB is stored.
'4) Added password parameter in case OtherDB secured.
'5) Now assumes tblModules exist.
'6) Added code to properly handle Property LET/GET/SET stmts.
'------------------------------------------------------------------------------
On Error GoTo ERR_EnumerateModules
Dim OtherDB As database
Dim strUserName As String
Dim strPass As String
Dim oAcc As Access.Application
Dim dbCurrent As database
Dim RS As Recordset
Dim doc As Document, rpt As Report, frm As Form
Dim mdl As Module, bolIsLoaded As Boolean, strDocName As String
Dim lngCount As Long, lngR As Long, intProcOrder As Integer
Dim lngCountDecl As Long, intI As Integer
Dim lngI As Long, lngCountProcLines As Long
Dim strProcName As String, strProcLines As String
Dim strModuleType() As String, intMT As Integer
Dim objTemp As Object, intModuleType As Integer
Dim strDBName As String, strDBPath As String
Dim strDrive As String, strDir As String, strFName As String, strExt As String
Dim varReturn As Variant
Dim lngOldProcType As Long, strOldProcName As String, strFinalProcName As String
DoCmd.Hourglass True
'clear table that will contain new module info
DoCmd.SetWarnings False
If bolEmptytable = True Then
DoCmd.RunSQL ("Delete * from tblModules")
End If
DoCmd.SetWarnings True
ReDim strModuleType(0 To 2)
strModuleType(0) = "Modules"
strModuleType(1) = "Forms"
strModuleType(2) = "Reports"
Call SplitPath(strPath, strDrive, strDir, strFName, strExt)
strDBPath = strDrive & strDir
strDBName = strFName & "." & strExt
'open recordset to tblModules in THIS database
Set dbCurrent = CurrentDb()
Set RS = dbCurrent.OpenRecordset("tblModules")
'open OTHER database
Set oAcc = New Access.Application
Set OtherDB = oAcc.DBEngine.OpenDatabase(strPath, False, False, ";PWD=" & strPassWord)
oAcc.OpenCurrentDatabase strPath
intProcOrder = 0
'Move through the modules
For intMT = 0 To 2 Step 1
For Each doc In OtherDB.Containers(strModuleType(intMT)).Documents
strDocName = doc.Name
Select Case strModuleType(intMT)
Case "Modules"
intModuleType = acModule
Case "Forms"
intModuleType = acForm
Case "Reports"
intModuleType = acReport
End Select
bolIsLoaded = IsObjectOpen(intModuleType, strDocName)
'you can't open the module if it's already open.
If bolIsLoaded = False Then
Select Case intModuleType
Case acModule
oAcc.DoCmd.OpenModule doc.Name
Set objTemp = oAcc.Modules(doc.Name)
Case acForm
oAcc.DoCmd.OpenForm strDocName, acDesign, , , acFormReadOnly, acWindowNormal
Set objTemp = oAcc.Forms(strDocName).Module
Case acReport
oAcc.DoCmd.OpenReport strDocName, acViewDesign
Set objTemp = oAcc.Reports(doc.Name).Module
End Select
Else
Select Case intModuleType
Case acModule
Set objTemp = Modules(doc.Name)
Case acForm
Set objTemp = Forms(doc.Name).Module
Case acReport
Set objTemp = Reports(doc.Name).Module
End Select
End If
'get number of lines in this module
lngCount = objTemp.CountOfLines
'Declarations
'find out how many lines in Declaration section
lngCountDecl = objTemp.CountOfDeclarationLines
'get code lines for Declaration section
strProcLines = objTemp.Lines(1, lngCountDecl)
Do Until (Asc(Left(strProcLines, 1)) <> 13 And Asc(Left(strProcLines, 1)) <> 10 _
And Asc(Left(strProcLines, 1)) <> 32)
strProcLines = Mid(strProcLines, 2)
Loop
Do Until (Asc(Right(strProcLines, 1)) <> 13 And Asc(Right(strProcLines, 1)) <> 10 _
And Asc(Right(strProcLines, 1)) <> 32)
strProcLines = Mid(strProcLines, 1, Len(strProcLines) - 1)
Loop
With RS
.AddNew
!DatabaseName = strDBName
!databasepath = strDBPath
!ModuleName = objTemp.Name
!CodeLinesCount = lngCount
!ModuleType = objTemp.Type
!ProcedureName = "Declarations"
!ProcedureLines = strProcLines
!ProcedureLinesCount = lngCountDecl
!ProcedureOrder = intProcOrder
.Update
End With
strOldProcName = "Declarations"
'Check to see if there is anything else after the declarations section
'Are there more lines in module than just the lines of Declaration?
If lngCount> lngCountDecl Then
'start at first line after Declaration section
intI = lngCountDecl + 1
intProcOrder = intProcOrder + 1
'***** Get Name of Proc of this line *********
'inti specifies the number of a line in the module.
'When return from getting the ProcOfLine,
'lngR will specify the type of procedure:
' vbext_pk_Get lngR=3 A Property Get proc
' vbext_pk_Let lngR=1 A Property Let proc
' vbext_pk_Proc lngR=0 A Sub or Function proc
' vbext_pk_Set lngR=2 A Property Set proc
strProcName = objTemp.ProcOfLine(intI, lngR)
'save proc name so will know when reach line with new proc
strOldProcName = strProcName
'save type of proc for next compare (to distinguish same-name Property stmts)
lngOldProcType = lngR
'If proc was a property stmt, add type to procname that will save in tblModules
Select Case lngOldProcType
Case vbext_pk_Proc
strFinalProcName = strProcName
Case vbext_pk_Get
strFinalProcName = strProcName & " [Property Get]"
Case vbext_pk_Let
strFinalProcName = strProcName & " [Property Let]"
Case vbext_pk_Set
strFinalProcName = strProcName & " [Property Set]"
End Select
'****** update progress display in status bar *****************
varReturn = SysCmd(acSysCmdSetStatus, "Processing " _
& strModuleType(intMT) & " " & doc.Name & ".... Procedure " & strFinalProcName)
'get the number of lines for this proc
lngCountProcLines = objTemp.ProcCountLines(strProcName, lngR)
'get the code lines for this proc
strProcLines = objTemp.Lines(intI, lngCountProcLines)
'strip CRLF's and SPACES from left side of codelines
Do Until (Asc(Left(strProcLines, 1)) <> 13 And Asc(Left(strProcLines, 1)) <> 10 _
And Asc(Left(strProcLines, 1)) <> 32)
strProcLines = Mid(strProcLines, 2)
Loop
'strip CRLF's and SPACES from right side of codelines
Do Until (Asc(Right(strProcLines, 1)) <> 13 And Asc(Right(strProcLines, 1)) <> 10 _
And Asc(Right(strProcLines, 1)) <> 32)
strProcLines = Mid(strProcLines, 1, Len(strProcLines) - 1)
Loop
'for html coding (you probably want to delete the following)
'if have a Proc (not a Property stmt),
'add "Sub" or "Function" to start of proc name
If lngOldProcType = vbext_pk_Proc Then
If Left(strProcLines, 15) = "Public Function" _
Or Left(strProcLines, 16) = "Private Function" Then
strFinalProcName = "Function " & strFinalProcName
Else
strFinalProcName = "Sub " & strFinalProcName
End If
End If
With RS
.AddNew
!DatabaseName = strDBName
!databasepath = strDBPath
!ModuleName = objTemp.Name
!CodeLinesCount = lngCount
!ModuleType = objTemp.Type
!ProcedureName = strFinalProcName
!ProcedureLines = strProcLines
!ProcedureLinesCount = lngCountProcLines
!ProcedureOrder = intProcOrder
.Update
End With
'Go through the rest of the module, enumerating the procedures
For lngI = intI To lngCount
'***** Get Name of Proc of this line *********
'inti specifies the number of a line in the module.
'When return from getting the ProcOfLine,
'lngR will specify the type of procedure:
' vbext_pk_Get lngR=3 A Property Get proc
' vbext_pk_Let lngR=1 A Property Let proc
' vbext_pk_Proc lngR=0 A Sub or Function proc
' vbext_pk_Set lngR=2 A Property Set proc
strProcName = objTemp.ProcOfLine(lngI, lngR)
'see if ProcName for this line has changed
'or ProcName is the same but have different ProcType
If (strProcName <> strOldProcName) _
Or ((strProcName = strOldProcName) And (lngR <> lngOldProcType)) Then
intProcOrder = intProcOrder + 1
'save proc name so will know when reach line with new proc
strOldProcName = strProcName
'save type of proc for next compare (to distinguish same-name Property stmts)
lngOldProcType = lngR
'If proc was a property stmt, add type to procname that will save in tblModules
Select Case lngOldProcType
Case vbext_pk_Proc
strFinalProcName = strProcName
Case vbext_pk_Get
strFinalProcName = strProcName & " [Property Get]"
Case vbext_pk_Let
strFinalProcName = strProcName & " [Property Let]"
Case vbext_pk_Set
strFinalProcName = strProcName & " [Property Set]"
End Select
'****** update progress display in status bar *****************
varReturn = SysCmd(acSysCmdSetStatus, "Processing " _
& strModuleType(intMT) & " " & doc.Name & ".... Procedure " & strFinalProcName)
'get the number of lines for this proc
lngCountProcLines = objTemp.ProcCountLines(strProcName, lngR)
'get the code lines for this proc
strProcLines = objTemp.Lines(lngI, lngCountProcLines)
'strip CRLF's and SPACES from left side of codelines
Do Until (Asc(Left(strProcLines, 1)) <> 13 And Asc(Left(strProcLines, 1)) <> 10 _
And Asc(Left(strProcLines, 1)) <> 32)
strProcLines = Mid(strProcLines, 2)
Loop
'strip CRLF's and SPACES from right side of codelines
Do Until (Asc(Right(strProcLines, 1)) <> 13 And Asc(Right(strProcLines, 1)) <> 10 _
And Asc(Right(strProcLines, 1)) <> 32)
strProcLines = Mid(strProcLines, 1, Len(strProcLines) - 1)
Loop
'for html coding (you probably want to delete the following)
'if have a Proc (not a Property stmt),
'add "Sub" or "Function" to start of proc name
If lngOldProcType = vbext_pk_Proc Then
If Left(strProcLines, 15) = "Public Function" _
Or Left(strProcLines, 16) = "Private Function" Then
strFinalProcName = "Function " & strFinalProcName
Else
strFinalProcName = "Sub " & strFinalProcName
End If
End If
With RS
.AddNew
!DatabaseName = strDBName
!databasepath = strDBPath
!ModuleName = objTemp.Name
!CodeLinesCount = lngCount
!ModuleType = objTemp.Type
!ProcedureName = strFinalProcName
!ProcedureLines = strProcLines
!ProcedureLinesCount = lngCountProcLines
!ProcedureOrder = intProcOrder
.Update
End With
End If
'look at next line in code module
Next lngI
'finished getting all info from this module
'/* End of If lngCount> lngCountDecl Then
End If
'reinit vars to get a new module
intProcOrder = 0
lngCountProcLines = 0
strProcLines = " "
No_Module:
'close object that contained last code module
Set objTemp = Nothing
oAcc.DoCmd.close intModuleType, doc.Name, acSaveNo
'go get another code module of the same module type
Next 'doc
'have gotten all code modules for this type
'so start getting another type of module
Next 'intMT
'****** update progress display in status bar *****************
varReturn = SysCmd(acSysCmdClearStatus)
MsgBox "Processing Complete"
EnumerateModules = True
EXIT_EnumerateModules:
oAcc.CloseCurrentDatabase
OtherDB.close: Set OtherDB = Nothing
RS.close: Set RS = Nothing
dbCurrent.close: Set dbCurrent = Nothing
DoCmd.Hourglass False
DoCmd.SetWarnings True
Exit Function
ERR_EnumerateModules:
EnumerateModules = False
MsgBox Err & ": " & Err.Description, vbCritical, _
"Error in function basModuleCode.EnumerateModules"
Resume EXIT_EnumerateModules
End Function
Sub SplitPath(strPath As String, _
strDrive As String, _
strDir As String, _
strFName As String, _
strExt As String)
Dim intPos As Integer ' current position of \
Dim intLast As Integer ' last position of \
Dim strTemp As String
If Len(strPath) < 3 Or IsNull(strPath) Then Exit Sub
strDrive = Left(strPath, 2)
'find position of last "\"
intPos = InStr(strPath, "\")
While intPos <> 0
intLast = intPos
intPos = InStr(intPos + 1, strPath, "\")
Wend
If intLast> 3 Then
strDir = Mid(strPath, 3, intLast - 3)
Else
strDir = ""
End If
'get FName and Ext
strTemp = Mid(strPath, intLast + 1)
intPos = InStr(strTemp, ".")
If intPos <> 0 Then 'found a "."
strExt = Mid(strTemp, intPos + 1)
strFName = Left(strTemp, intPos - 1)
Else 'did not find "." so no extension
strExt = ""
strFName = strTemp
End If
End Sub
Private Sub Create_tblModules_Table()
Dim tdf As TableDef
Dim idxPrimary As index
Set tdf = CurrentDb.CreateTableDef("tblModules")
With tdf
.Fields.Append .CreateField("DatabaseName", dbText, 50)
.Fields.Append .CreateField("DatabasePath", dbText, 255)
.Fields.Append .CreateField("ModuleName", dbText, 50)
.Fields.Append .CreateField("ProcedureOrder", dbLong)
.Fields.Append .CreateField("ProcedureName", dbText, 50)
.Fields.Append .CreateField("ProcedureLines", dbMemo)
.Fields.Append .CreateField("ProcedureLinesCount", dbLong)
.Fields.Append .CreateField("CodeLinesCount", dbLong)
.Fields.Append .CreateField("ModuleType", dbLong)
End With
CurrentDb.TableDefs.Append tdf
Set tdf = Nothing
End Sub
'******** Code Ends Here ********
_________________________________________________________________
Going green? See the top 12 foods to eat organic.
http://green.msn.com/galleries/photos/photos.aspx?gid=164&ocid=T003MSN51N1653A