none
Procedure callers RRS feed

  • Question

  • Hi All,

    I know the method to list all procedures/functions in a project but I was wondering if there is also a method to add the callers.

    I have MZTools 8 (latest version) installed and know how to find the callers of the sub/function and this is very useful but not very handy to scan 10ths (100ths) of subs/functions.

    After some years of working on the same project it is obvious that some code gets recalled by several uppper level subs and in most cases extensions/corrections were made by adding additional arguments but that is of course increasing the complexity of maintaining it because some arguments are specific to one call and IMO it world be better to separate them to more low level subs.

    Starting from scratch mostly generates a lot of errors, so not a very good approach. Any thoughs that can be helpful?

    Friday, August 18, 2017 3:43 PM

Answers

  • Hi Fei,

    I'm programmning in VBA and wrote some code that fairly do what I need. Of course susceptible for improvements. It is a mixt of code published by Jon Peltier & Chip Pearson.

    It may need some explanation. It needs a reference to the scripting.runtime and the vba extensibility library.

    First I add a sheet ("ListAllProcedures") and a module to the project.

    In the code following constants must be adapted:

    Const MY_MODULE = "Module1"
    Const MY_SHEET = "ListAllProcedures"
    Const MY_SHEET_CODENAME = "Sheet14"

    In the Sub GetProcedures you can specify the modules to report:

    For Each objComp In objProj.VBComponents
          VBCompType = objComp.Type
          ''' specify the type of module to analyze
          Select Case VBCompType
             Case vbext_ct_StdModule:
             Case vbext_ct_MSForm:            'GoTo NextMod
             Case vbext_ct_Document:
             Case vbext_ct_ClassModule:       'GoTo NextMod
             Case Else:                       GoTo NextMod
          End Selec

    And in Sub ExcludeSub the subs to exclude.

    Private Sub ExcludeSub()
       Set mdicExclude = New Dictionary
       mdicExclude.CompareMode = TextCompare
       With mdicExclude
          .Add Key:="UserForm_Initialize", Item:=1
          .Add Key:="UserForm_QueryClose", Item:=1
          .Add Key:="cmdHlp_Click", Item:=1
       End With
    End Sub

    After running GetProcedures  we have all sub to further evaluate with GetProcedureCallers

    The most important part is Function EvaluateLine. This one says if the sub was called or not.

    Some tricky situations have to handled e.g. line continuation. Easy enough to check if a single line is comment but what looks as a statement can still be a comment when looking at the first line of the continuations.

    Then the dot preceding the Sub_Name. When it is called as module_name.sub_name ok but else consider it as a property/method. I came to this because a class module had a property name and you know how often .name can appear.

    Last as literal. Ok when called as Application.Run but else ignore.

    Fully realizing that it can be improved and that some reported items will not be correct but it is a starting point.

    The intention is indeed to split the code into lower level subs/functions but also to rebuild the complete project.

    For the one who is trying the code, it may take several seconds (60 to 95 in my case: 41 clases, 37 modules, 537 methods & 41 properties)

    Full code hereafter:

    Option Explicit

    ''' adapt following constants to your workbook
    Const MY_MODULE = "Module1"
    Const MY_SHEET = "ListAllProcedures"
    Const MY_SHEET_CODENAME = "Sheet14"

    ''' exclude some common subs
    Private mdicExclude As Dictionary

    Private VBCompType As VBIDE.vbext_ComponentType

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : GetProcedures
    ''' Author ©   : Jon Peltier
    ''' Date       : 10/12/2009
    '''---------------------------------------------------------------------------------------
    ''' Modified by Jean-Pierre Degroote AKA JP Ronse
    Sub GetProcedures()
       ' Declare variables to access the Excel workbook.
       Dim objApp As Excel.Application
       'Dim wb As Excel.Workbook
       Dim objOutput As Excel.Worksheet
       Dim strOutput() As String
       Dim strFileName As String

       ' Declare variables to access the macros in the workbook.
       Dim objProj As VBIDE.VBProject
       Dim objComp As VBIDE.VBComponent
       Dim objMod As VBIDE.CodeModule

       ' Declare other miscellaneous variables.
       Dim lngRow As Long
       Dim lngCol As Long
       Dim intLine As Integer
       Dim strProcName As String
       Dim enmPk As vbext_ProcKind
       
       Call ExcludeSub
       
       Set objApp = Excel.Application
       Set objProj = objApp.ThisWorkbook.VBProject
       Set objProj = objApp.VBE.ActiveVBProject
       
       ''' make sure that the sheet MY_SHEET exist.
       Set objOutput = ThisWorkbook.Sheets(MY_SHEET)
       
       ' Get the project details in the workbook.
       On Error Resume Next
       strFileName = objProj.fileName
       If Err.Number <> 0 Then strFileName = "file not saved"
       On Error GoTo 0

       ' initialize output array
       ReDim strOutput(1 To 2)
       strOutput(1) = strFileName
       strOutput(2) = objProj.Name
       lngRow = 0

       ' Iterate through each component in the project.
       For Each objComp In objProj.VBComponents
          VBCompType = objComp.Type
          ''' specify the type of module to analyze
          Select Case VBCompType
             Case vbext_ct_StdModule:
             Case vbext_ct_MSForm:            'GoTo NextMod
             Case vbext_ct_Document:
             Case vbext_ct_ClassModule:       'GoTo NextMod
             Case Else:                       GoTo NextMod
          End Select
          ' Find the code module for the project.
          Set objMod = objComp.CodeModule
          If objMod.Name = MY_MODULE Then GoTo NextMod
          ' Scan through the code module, looking for procedures.
          intLine = 1
          Do While intLine < objMod.CountOfLines
             strProcName = objMod.ProcOfLine(intLine, enmPk)
             If mdicExclude.Exists(strProcName) Then strProcName = ""
             If strProcName <> "" And Not mdicExclude.Exists(strProcName) Then
                lngRow = lngRow + 1
                ReDim Preserve strOutput(1 To 2 + lngRow)
                strOutput(2 + lngRow) = objComp.Name & ": " & strProcName
                intLine = intLine + objMod.ProcCountLines(strProcName, enmPk)
             Else
                ' This line has no procedure, so go to the next line.
                intLine = intLine + 1
             End If
          Loop
    NextMod:
          ' clean up
          Set objMod = Nothing
          Set objComp = Nothing

       Next
       
       ' define output location and dump output
       If Len(objOutput.Range("A1").Value) = 0 Then
          lngCol = 1
       Else
          lngCol = objOutput.Cells(1, objOutput.Columns.Count).End(xlToLeft).Column + 1
       End If
       objOutput.Cells(1, lngCol).Resize(UBound(strOutput) + 1 - LBound(strOutput)).Value = _
          WorksheetFunction.Transpose(strOutput)

       ' clean up
       Set objMod = Nothing
       Set objComp = Nothing
       Set objProj = Nothing
       'Next

       ' clean up
       objOutput.UsedRange.Columns.AutoFit
    End Sub

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : GetProcedures
    ''' Author ©   : Jean-Pierre Degroote AKA JP Ronse
    ''' Date       : 21/08/2017
    '''---------------------------------------------------------------------------------------
    Sub GetProcedureCallers()
       ' Declare variables to access the Excel workbook.
       Dim objApp As Excel.Application
       Dim objOutput As Excel.Worksheet
       Dim varProc As Variant
       Dim intcount As Integer
       Dim t As Double
       ' Declare variables to access the macros in the workbook.
       Dim objProj As VBIDE.VBProject
       Dim objComp As VBIDE.VBComponent
       Dim objMod As VBIDE.CodeModule
       Dim intPos  As Integer
       Dim blnFound As Boolean
       Dim lngStartLine As Long ' start line
       Dim lngEndLine As Long ' end line
       Dim lngStartColumn As Long ' start column
       Dim lngEndColumn As Long ' end column
       Dim blnEvaluate As Boolean
       Dim strParentMod As String
       
       ' Declare other miscellaneous variables.
       'Dim lngRow As Long
       Dim lngCol As Long
       Dim intLine As Integer
       Dim strProcName As String
       Dim enmPk As vbext_ProcKind

       t = Timer
       Application.ScreenUpdating = False
       Application.EnableEvents = False
       Application.Calculation = xlCalculationManual
       
       Set objApp = Excel.Application

       ' create new workbook for output
       Set objProj = objApp.VBE.ActiveVBProject
       Set objOutput = ThisWorkbook.Sheets("ListAllProcedures")
       
       varProc = objOutput.Range("A1").CurrentRegion
       
       For intcount = 3 To UBound(varProc, 1)
       'For intCount = 132 To 132
          lngCol = 2
          
          ' Iterate through each component in the project.
          For Each objComp In objProj.VBComponents
             ' Find the code module for the project.
             Set objMod = objComp.CodeModule
             'If objMod.Name = "modAPPListener" Then Stop
             ' Scan through the code module, looking for procedures.
             ''' skip the added sheet "ListAllProcedures" and
             ''' the module with this code
             ''' adapt next statement to your specs
             If objMod.Name = MY_SHEET_CODENAME Or objMod.Name = MY_MODULE Then GoTo Continue
             
             intLine = 1
             strProcName = Trim$(Split(varProc(intcount, 1), ":")(1))
             strParentMod = Trim$(Split(varProc(intcount, 1), ":")(0))
             
             With objMod
                lngStartLine = 1
                lngEndLine = .CountOfLines
                lngStartColumn = 1
                lngEndColumn = 255
                
                blnFound = .Find(Target:=strProcName, Startline:=lngStartLine, _
                   StartColumn:=lngStartColumn, EndLine:=lngEndLine, EndColumn:=lngEndColumn, _
                   WholeWord:=True, MatchCase:=True, PatternSearch:=False)
                Do Until blnFound = False
                   'Debug.Print "Found at: Line: " & CStr(lngStartLine) & " Column: " & CStr(lngStartColumn)
                   blnEvaluate = EvaluateLine(objMod, strParentMod, strProcName, lngStartLine, lngStartColumn)
                   If blnEvaluate Then
                      ''' do not report a sub twice and do not report the reference sub
                      If (Cells(intcount, lngCol - 1) <> objMod.Name & ": " & objMod.ProcOfLine(lngStartLine, vbext_pk_Proc)) And (Cells(intcount, 1) <> objMod.Name & ": " & objMod.ProcOfLine(lngStartLine, vbext_pk_Proc)) Then
                         Cells(intcount, lngCol) = objMod.Name & ": " & objMod.ProcOfLine(lngStartLine, vbext_pk_Proc)
                         lngCol = lngCol + 1
                      End If

                   End If
                   lngEndLine = .CountOfLines
                   lngStartColumn = lngEndColumn + 1
                   lngEndColumn = 255
                   
                   blnFound = .Find(Target:=strProcName, Startline:=lngStartLine, _
                   StartColumn:=lngStartColumn, EndLine:=lngEndLine, EndColumn:=lngEndColumn, _
                   WholeWord:=True, MatchCase:=True, PatternSearch:=False)
                Loop
                
             End With

    Continue:
             ' clean up
             Set objMod = Nothing
             Set objComp = Nothing

          Next
       Next intcount

       ' clean up
       Set objMod = Nothing
       Set objComp = Nothing
       Set objProj = Nothing
       'Next

       ' clean up
       objOutput.UsedRange.Columns.AutoFit
       Application.ScreenUpdating = True
       Application.EnableEvents = True
       Application.Calculation = xlCalculationAutomatic
       Debug.Print Timer - t
    End Sub

    Private Function EvaluateLine(CodeMod As VBIDE.CodeModule, ParentMod, FindWhat, MyLine, MyColumn) As Boolean
       Dim lngStartLine As Long
       Dim strLine As String
       Dim intcount As Integer
       
       '''Debug.Print CodeMod.Name
       ''' get the full line
       lngStartLine = MyLine
       strLine = ""
       Do Until Right(CodeMod.Lines(lngStartLine - 1, 1), 1) <> "_"
          lngStartLine = lngStartLine - 1
       Loop
          
       ''' combine the lines
       For intcount = lngStartLine To MyLine
          strLine = strLine & CodeMod.Lines(intcount, 1)
       Next intcount
       
       ''' remove comment
       On Error Resume Next
       strLine = Left(strLine, InStr(1, strLine, "'", vbBinaryCompare) - 1)
       On Error GoTo 0
       
       ''' check if FindWhat is still in strLine
       If InStr(1, strLine, FindWhat, vbBinaryCompare) Then
          If InStr(1, strLine, "." & FindWhat, vbBinaryCompare) Then
             If InStr(1, strLine, ParentMod & "." & FindWhat, vbBinaryCompare) Then
                EvaluateLine = True
             Else
                EvaluateLine = False
             End If
          Else
             ''' if it is not the first argument of application.run, it is comment
             If InStr(1, strLine, Chr(34) & FindWhat, vbBinaryCompare) Then
                
                If InStr(1, strLine, "Application.Run", vbBinaryCompare) Then
                   EvaluateLine = True
                Else
                   EvaluateLine = False
                End If
             Else
                EvaluateLine = True
             End If
          End If
       Else
         EvaluateLine = False
       End If
    End Function

    Private Sub ExcludeSub()
       Set mdicExclude = New Dictionary
       mdicExclude.CompareMode = TextCompare
       With mdicExclude
          .Add Key:="UserForm_Initialize", Item:=1
          .Add Key:="UserForm_QueryClose", Item:=1
          .Add Key:="cmdHlp_Click", Item:=1
       End With
    End Sub


    • Marked as answer by JP Ronse Monday, August 28, 2017 11:41 AM
    Thursday, August 24, 2017 2:19 PM

All replies

  • Hi JP Ronse,

    As far as I know, there is no programmatic way in VBA to get caller of subs/functions. We could use Call Stack to see the caller of a sub at runtime. But the Call Stack is not VBA function, it is a dialog view to show the caller.

    Best Regards,

    Terry

    Tuesday, August 22, 2017 2:43 AM
  • Hi Terry,

    Thanks for the reply. I know the call stack but that would be a very tough method because it implies that all possible calls have to be tested. Big chance that some are forgotten. As said, MZTools can do it one by one but with some 100 procedures makes it also a tedious job.

    I dived into some code of Jon Peltier and Chip Pearson and IMHO it should be feasible to work it out. Maybe not a 100% correct solution but fair enough. It is easy enough to find if a procedure name appears in another module/procedure but the issues are:

    1. It should not be included in a comment. Easy enough to check if the line starts with a single quote.
    2. It should not be a property/method of something else.  IMO it can be catched to check if the preceding character is a dot or not.
    3. More difficult is the calling method: procedure, call procedure, application.run("procudure") , anyhow I think it is possible to test it.
    4. It should not be an argument of something else. Have to think how it can be detected.
    5. Line continuation can be misleading. Say a line is beginning as comment line and ending with "_", the second (Nth line) can contain the procedure name but it is still a comment. At tis time I have the idea to look in the previous lines until the start-line is found.

    If you see other issues, please let me know.

    Although I'm programming in VBA for years, programming in the VBIDE is rather new to me. As soon as I have some "acceptable" code, I'll post it here but give me some days.

    Kind regards,

    JP

    Tuesday, August 22, 2017 2:11 PM
  • Hi JP,

    Are you developing with VBA or VB.Net? If you were developing VB.Net, we can easily to find the caller using the Visual Studio via right click the method->Find All References. If you were developing VBA, the VBE doesn't support this feature. 

    A possible way to refactor the code in the VBE is that we need to find all the method name event it in the comment or other places. We must check it manually to see whether we need to modify it. For example, if we split method A to two methods B and C, we need to replace method A everywhere to clear the confuse event it only shows in the comment.

    >After some years of working on the same project it is obvious that some code gets recalled by several uppper level subs and in most cases extensions/corrections were made by adding additional arguments but that is of course increasing the complexity of maintaining it because some arguments are specific to one call and IMO it world be better to separate them to more low level subs.

    Did you mean you want to split the orignal function to low level subs? If I understood correctly, it shouldn't affect the caller of this function.

    For example, we have a complex method like below: 

    Function SumAndMul(p1 As Integer, p2 As Integer)
    SumAndMul = p1 + p2 + p1 * p2
    End Function
    

    Then we want to  separate them to more low level subs, then this function could be like 

    Function Sum(p1 As Integer, p2 As Integer)
    Sum = p1 + p2
    End Function
    
    
    Function Mul(p1 As Integer, p2 As Integer)
    Mul = p1 * p2
    End Function
    
    Function SumAndMul(p1 As Integer, p2 As Integer)
    SumAndMul = Sum(p1, p2) + Mul(p1, p2)
    End Function

    This will not affect the caller for the function SumAndMul since we only change the function instead of change its signature. Please feel free to let me know if I misunderstood.

    Regards & Fei


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Thursday, August 24, 2017 7:47 AM
    Moderator
  • Hi Fei,

    I'm programmning in VBA and wrote some code that fairly do what I need. Of course susceptible for improvements. It is a mixt of code published by Jon Peltier & Chip Pearson.

    It may need some explanation. It needs a reference to the scripting.runtime and the vba extensibility library.

    First I add a sheet ("ListAllProcedures") and a module to the project.

    In the code following constants must be adapted:

    Const MY_MODULE = "Module1"
    Const MY_SHEET = "ListAllProcedures"
    Const MY_SHEET_CODENAME = "Sheet14"

    In the Sub GetProcedures you can specify the modules to report:

    For Each objComp In objProj.VBComponents
          VBCompType = objComp.Type
          ''' specify the type of module to analyze
          Select Case VBCompType
             Case vbext_ct_StdModule:
             Case vbext_ct_MSForm:            'GoTo NextMod
             Case vbext_ct_Document:
             Case vbext_ct_ClassModule:       'GoTo NextMod
             Case Else:                       GoTo NextMod
          End Selec

    And in Sub ExcludeSub the subs to exclude.

    Private Sub ExcludeSub()
       Set mdicExclude = New Dictionary
       mdicExclude.CompareMode = TextCompare
       With mdicExclude
          .Add Key:="UserForm_Initialize", Item:=1
          .Add Key:="UserForm_QueryClose", Item:=1
          .Add Key:="cmdHlp_Click", Item:=1
       End With
    End Sub

    After running GetProcedures  we have all sub to further evaluate with GetProcedureCallers

    The most important part is Function EvaluateLine. This one says if the sub was called or not.

    Some tricky situations have to handled e.g. line continuation. Easy enough to check if a single line is comment but what looks as a statement can still be a comment when looking at the first line of the continuations.

    Then the dot preceding the Sub_Name. When it is called as module_name.sub_name ok but else consider it as a property/method. I came to this because a class module had a property name and you know how often .name can appear.

    Last as literal. Ok when called as Application.Run but else ignore.

    Fully realizing that it can be improved and that some reported items will not be correct but it is a starting point.

    The intention is indeed to split the code into lower level subs/functions but also to rebuild the complete project.

    For the one who is trying the code, it may take several seconds (60 to 95 in my case: 41 clases, 37 modules, 537 methods & 41 properties)

    Full code hereafter:

    Option Explicit

    ''' adapt following constants to your workbook
    Const MY_MODULE = "Module1"
    Const MY_SHEET = "ListAllProcedures"
    Const MY_SHEET_CODENAME = "Sheet14"

    ''' exclude some common subs
    Private mdicExclude As Dictionary

    Private VBCompType As VBIDE.vbext_ComponentType

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : GetProcedures
    ''' Author ©   : Jon Peltier
    ''' Date       : 10/12/2009
    '''---------------------------------------------------------------------------------------
    ''' Modified by Jean-Pierre Degroote AKA JP Ronse
    Sub GetProcedures()
       ' Declare variables to access the Excel workbook.
       Dim objApp As Excel.Application
       'Dim wb As Excel.Workbook
       Dim objOutput As Excel.Worksheet
       Dim strOutput() As String
       Dim strFileName As String

       ' Declare variables to access the macros in the workbook.
       Dim objProj As VBIDE.VBProject
       Dim objComp As VBIDE.VBComponent
       Dim objMod As VBIDE.CodeModule

       ' Declare other miscellaneous variables.
       Dim lngRow As Long
       Dim lngCol As Long
       Dim intLine As Integer
       Dim strProcName As String
       Dim enmPk As vbext_ProcKind
       
       Call ExcludeSub
       
       Set objApp = Excel.Application
       Set objProj = objApp.ThisWorkbook.VBProject
       Set objProj = objApp.VBE.ActiveVBProject
       
       ''' make sure that the sheet MY_SHEET exist.
       Set objOutput = ThisWorkbook.Sheets(MY_SHEET)
       
       ' Get the project details in the workbook.
       On Error Resume Next
       strFileName = objProj.fileName
       If Err.Number <> 0 Then strFileName = "file not saved"
       On Error GoTo 0

       ' initialize output array
       ReDim strOutput(1 To 2)
       strOutput(1) = strFileName
       strOutput(2) = objProj.Name
       lngRow = 0

       ' Iterate through each component in the project.
       For Each objComp In objProj.VBComponents
          VBCompType = objComp.Type
          ''' specify the type of module to analyze
          Select Case VBCompType
             Case vbext_ct_StdModule:
             Case vbext_ct_MSForm:            'GoTo NextMod
             Case vbext_ct_Document:
             Case vbext_ct_ClassModule:       'GoTo NextMod
             Case Else:                       GoTo NextMod
          End Select
          ' Find the code module for the project.
          Set objMod = objComp.CodeModule
          If objMod.Name = MY_MODULE Then GoTo NextMod
          ' Scan through the code module, looking for procedures.
          intLine = 1
          Do While intLine < objMod.CountOfLines
             strProcName = objMod.ProcOfLine(intLine, enmPk)
             If mdicExclude.Exists(strProcName) Then strProcName = ""
             If strProcName <> "" And Not mdicExclude.Exists(strProcName) Then
                lngRow = lngRow + 1
                ReDim Preserve strOutput(1 To 2 + lngRow)
                strOutput(2 + lngRow) = objComp.Name & ": " & strProcName
                intLine = intLine + objMod.ProcCountLines(strProcName, enmPk)
             Else
                ' This line has no procedure, so go to the next line.
                intLine = intLine + 1
             End If
          Loop
    NextMod:
          ' clean up
          Set objMod = Nothing
          Set objComp = Nothing

       Next
       
       ' define output location and dump output
       If Len(objOutput.Range("A1").Value) = 0 Then
          lngCol = 1
       Else
          lngCol = objOutput.Cells(1, objOutput.Columns.Count).End(xlToLeft).Column + 1
       End If
       objOutput.Cells(1, lngCol).Resize(UBound(strOutput) + 1 - LBound(strOutput)).Value = _
          WorksheetFunction.Transpose(strOutput)

       ' clean up
       Set objMod = Nothing
       Set objComp = Nothing
       Set objProj = Nothing
       'Next

       ' clean up
       objOutput.UsedRange.Columns.AutoFit
    End Sub

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''' Name       : GetProcedures
    ''' Author ©   : Jean-Pierre Degroote AKA JP Ronse
    ''' Date       : 21/08/2017
    '''---------------------------------------------------------------------------------------
    Sub GetProcedureCallers()
       ' Declare variables to access the Excel workbook.
       Dim objApp As Excel.Application
       Dim objOutput As Excel.Worksheet
       Dim varProc As Variant
       Dim intcount As Integer
       Dim t As Double
       ' Declare variables to access the macros in the workbook.
       Dim objProj As VBIDE.VBProject
       Dim objComp As VBIDE.VBComponent
       Dim objMod As VBIDE.CodeModule
       Dim intPos  As Integer
       Dim blnFound As Boolean
       Dim lngStartLine As Long ' start line
       Dim lngEndLine As Long ' end line
       Dim lngStartColumn As Long ' start column
       Dim lngEndColumn As Long ' end column
       Dim blnEvaluate As Boolean
       Dim strParentMod As String
       
       ' Declare other miscellaneous variables.
       'Dim lngRow As Long
       Dim lngCol As Long
       Dim intLine As Integer
       Dim strProcName As String
       Dim enmPk As vbext_ProcKind

       t = Timer
       Application.ScreenUpdating = False
       Application.EnableEvents = False
       Application.Calculation = xlCalculationManual
       
       Set objApp = Excel.Application

       ' create new workbook for output
       Set objProj = objApp.VBE.ActiveVBProject
       Set objOutput = ThisWorkbook.Sheets("ListAllProcedures")
       
       varProc = objOutput.Range("A1").CurrentRegion
       
       For intcount = 3 To UBound(varProc, 1)
       'For intCount = 132 To 132
          lngCol = 2
          
          ' Iterate through each component in the project.
          For Each objComp In objProj.VBComponents
             ' Find the code module for the project.
             Set objMod = objComp.CodeModule
             'If objMod.Name = "modAPPListener" Then Stop
             ' Scan through the code module, looking for procedures.
             ''' skip the added sheet "ListAllProcedures" and
             ''' the module with this code
             ''' adapt next statement to your specs
             If objMod.Name = MY_SHEET_CODENAME Or objMod.Name = MY_MODULE Then GoTo Continue
             
             intLine = 1
             strProcName = Trim$(Split(varProc(intcount, 1), ":")(1))
             strParentMod = Trim$(Split(varProc(intcount, 1), ":")(0))
             
             With objMod
                lngStartLine = 1
                lngEndLine = .CountOfLines
                lngStartColumn = 1
                lngEndColumn = 255
                
                blnFound = .Find(Target:=strProcName, Startline:=lngStartLine, _
                   StartColumn:=lngStartColumn, EndLine:=lngEndLine, EndColumn:=lngEndColumn, _
                   WholeWord:=True, MatchCase:=True, PatternSearch:=False)
                Do Until blnFound = False
                   'Debug.Print "Found at: Line: " & CStr(lngStartLine) & " Column: " & CStr(lngStartColumn)
                   blnEvaluate = EvaluateLine(objMod, strParentMod, strProcName, lngStartLine, lngStartColumn)
                   If blnEvaluate Then
                      ''' do not report a sub twice and do not report the reference sub
                      If (Cells(intcount, lngCol - 1) <> objMod.Name & ": " & objMod.ProcOfLine(lngStartLine, vbext_pk_Proc)) And (Cells(intcount, 1) <> objMod.Name & ": " & objMod.ProcOfLine(lngStartLine, vbext_pk_Proc)) Then
                         Cells(intcount, lngCol) = objMod.Name & ": " & objMod.ProcOfLine(lngStartLine, vbext_pk_Proc)
                         lngCol = lngCol + 1
                      End If

                   End If
                   lngEndLine = .CountOfLines
                   lngStartColumn = lngEndColumn + 1
                   lngEndColumn = 255
                   
                   blnFound = .Find(Target:=strProcName, Startline:=lngStartLine, _
                   StartColumn:=lngStartColumn, EndLine:=lngEndLine, EndColumn:=lngEndColumn, _
                   WholeWord:=True, MatchCase:=True, PatternSearch:=False)
                Loop
                
             End With

    Continue:
             ' clean up
             Set objMod = Nothing
             Set objComp = Nothing

          Next
       Next intcount

       ' clean up
       Set objMod = Nothing
       Set objComp = Nothing
       Set objProj = Nothing
       'Next

       ' clean up
       objOutput.UsedRange.Columns.AutoFit
       Application.ScreenUpdating = True
       Application.EnableEvents = True
       Application.Calculation = xlCalculationAutomatic
       Debug.Print Timer - t
    End Sub

    Private Function EvaluateLine(CodeMod As VBIDE.CodeModule, ParentMod, FindWhat, MyLine, MyColumn) As Boolean
       Dim lngStartLine As Long
       Dim strLine As String
       Dim intcount As Integer
       
       '''Debug.Print CodeMod.Name
       ''' get the full line
       lngStartLine = MyLine
       strLine = ""
       Do Until Right(CodeMod.Lines(lngStartLine - 1, 1), 1) <> "_"
          lngStartLine = lngStartLine - 1
       Loop
          
       ''' combine the lines
       For intcount = lngStartLine To MyLine
          strLine = strLine & CodeMod.Lines(intcount, 1)
       Next intcount
       
       ''' remove comment
       On Error Resume Next
       strLine = Left(strLine, InStr(1, strLine, "'", vbBinaryCompare) - 1)
       On Error GoTo 0
       
       ''' check if FindWhat is still in strLine
       If InStr(1, strLine, FindWhat, vbBinaryCompare) Then
          If InStr(1, strLine, "." & FindWhat, vbBinaryCompare) Then
             If InStr(1, strLine, ParentMod & "." & FindWhat, vbBinaryCompare) Then
                EvaluateLine = True
             Else
                EvaluateLine = False
             End If
          Else
             ''' if it is not the first argument of application.run, it is comment
             If InStr(1, strLine, Chr(34) & FindWhat, vbBinaryCompare) Then
                
                If InStr(1, strLine, "Application.Run", vbBinaryCompare) Then
                   EvaluateLine = True
                Else
                   EvaluateLine = False
                End If
             Else
                EvaluateLine = True
             End If
          End If
       Else
         EvaluateLine = False
       End If
    End Function

    Private Sub ExcludeSub()
       Set mdicExclude = New Dictionary
       mdicExclude.CompareMode = TextCompare
       With mdicExclude
          .Add Key:="UserForm_Initialize", Item:=1
          .Add Key:="UserForm_QueryClose", Item:=1
          .Add Key:="cmdHlp_Click", Item:=1
       End With
    End Sub


    • Marked as answer by JP Ronse Monday, August 28, 2017 11:41 AM
    Thursday, August 24, 2017 2:19 PM