Option Explicit
' This requires a Reference to Microsoft Visual Basic for Applications Extensibility 5.3
Const TRACER_CLASSNAME As String = "cls_Tracer"

Public Sub InstrumentProcs()
   Dim ProjName As String, VBProj As VBIDE.VBProject
   ProjName = InputBox("Enter the name of the VBProject to insert trace calls", "Code Profiling / Tracing", ActiveWorkbook.VBProject.Name)
   If Len(ProjName) > 0 Then ' empty if Escaped
      Set VBProj = Application.VBE.VBProjects(ProjName)

     ' supply the Tracer Class first, to prevent compile errors
      AddTracerClass VBProj

      InstrumentCode VBProj:=VBProj, _
                  ProfileProcName:="Dim P_ as new " & TRACER_CLASSNAME & ": P_.Start "
      
      MsgBox "Save and close " & ProjName & " and re-open to test it"
      
   End If
End Sub



Public Sub AddTracerClass(VBProj As VBIDE.VBProject)
   Dim VBCOMP As VBIDE.VBComponent
   Dim CodeMod As VBIDE.CodeModule
   
   Set VBCOMP = VBProj.VBComponents.Add(vbext_ct_ClassModule)
   VBCOMP.Name = TRACER_CLASSNAME ' Class used in proc entry calls
   VBCOMP.CodeModule.InsertLines 1, _
      "'Class for Tracer calls " & Now() & vbCrLf & _
      "Private Declare Sub OutputDebugString Lib ""kernel32"" Alias ""OutputDebugStringA"" (ByVal lpOutputString As String)" & vbCrLf & _
      "Dim Procname As String" & vbCrLf & _
      "Sub Start(Subname As String)" & vbCrLf & _
      "Procname = Subname" & vbCrLf & _
      "OutputDebugString "","" & Procname & "",1""" & vbCrLf & _
      "End Sub" & vbCrLf & _
      "'This depends on a public sub O that does the output" & vbCrLf & _
      "Private Sub Class_Terminate()" & vbCrLf & _
      "OutputDebugString "","" & Procname & "",-1""" & vbCrLf & _
      "End Sub" & vbCrLf
End Sub

'some code from http://www.cpearson.com/excel/InsertProcedureNames.aspx
Public Sub InstrumentCode(VBProj As VBIDE.VBProject, ProfileProcName As String)
   
   ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   ' Insert a Profiling call to begin & end of each proc
   ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   Dim Procname As String
   Dim ProcType As VBIDE.vbext_ProcKind
   Dim ProcStartLine As Long, ProcEndLine As Long, ProcDeclarationLine As Long, ProcCodeLine As Long
   
   Dim VBCOMP As VBIDE.VBComponent
   Dim CodeMod As VBIDE.CodeModule
   Dim LineNum As Long
   Dim LineText As String
   Dim bProfileThis As Boolean
   
   If VBProj.Protection = vbext_pp_locked Then
       MsgBox "The project is locked.", vbOKOnly, "Tracer"
       Exit Sub
   End If
   
' we could loop through Application.VBE.ActiveCodePanes collection to operate on only the visible ones
   
' Loop through all modules in the Project
For Each VBCOMP In VBProj.VBComponents
   Set CodeMod = VBCOMP.CodeModule

   If Not CodeMod.Name = TRACER_CLASSNAME Then ' don't trace ourself
      '''''''''''''''''''''''''''''''''''''''''''''''''''
      ' Skip past any Option statement and any module-level
      ' variable declations. Start at the first procedure
      ' in the module.
      '''''''''''''''''''''''''''''''''''''''''''''''''''
      'CodeMod.CountOfDeclarationLines is the line before the first solid line across the codepane
      ' 0 for blank modules
      ' it includes comments up to the first blank line if any.
      ' but comments contiguous with the next procedure are counted with it.
      ' The +1 is simply to get the first proc name in the module, its actual start line is obtained later
      ' First proc name may be blank if there are no procs in this module, only declaration lines
      
      LineNum = CodeMod.CountOfDeclarationLines + 1 ' point anywhere after the declaration lines to init this.
      ' The real start line is obtained from ProcBodyLine below
      Procname = CodeMod.ProcOfLine(LineNum, ProcType)
      ' this is empty if there are no procedures in the module
      If Len(Procname) = 0 Then
         LineNum = CodeMod.CountOfLines
         ' skip this module if no code at all
         ' CodeMod.ProcBodyLine("" crashes Excel
      End If
   
      '''''''''''''''''''''''''''''''''''''''''''''''''''''
      ' Loop through all procedures in the module.
      '''''''''''''''''''''''''''''''''''''''''''''''''''''
      
      Do Until LineNum >= CodeMod.CountOfLines ' we change the line count as we insert
        DoEvents ' until end of module
      
        ''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' Get the procedure name that includes ProcStartLine in its lines.
        ' including lines before it, in it, or after it.
        ''''''''''''''''''''''''''''''''''''''''''''''''''''
      
        ProcStartLine = LineNum ' record where we started this proc
   
        Procname = CodeMod.ProcOfLine(ProcStartLine, ProcType)
        
          '''''''''''''''''''''''''''''''''''''''''''''''''''''
          ' Get the the actual declaration line, ignoring comments
          ''''''''''''''''''''''''''''''''''''''''''''''''''''''
      
        ProcDeclarationLine = CodeMod.ProcBodyLine(Procname, ProcType)   ' line of Sub whatsit()
        ProcEndLine = ProcStartLine + CodeMod.ProcCountLines(Procname, ProcType) - 1
          
        ' extract func / sub declaration for debug purposes only, not used below
        ProcCodeLine = ProcDeclarationLine
        LineText = " "
        Do
           LineText = Left(LineText, Len(LineText) - 1) & LTrim(CodeMod.Lines(ProcCodeLine, 1))
           ProcCodeLine = ProcCodeLine + 1
        Loop Until Right(LineText, 1) <> "_"
        ' at this point ProcCodeLine is first line AFTER proc header with any continuation
        
        LineNum = ProcCodeLine
        ' Don't profile one-liner Declares at top of a module
         bProfileThis = InStr(1, LineText, "Declare Sub") = 0 And InStr(1, LineText, "Declare Function") = 0
         'ProfileProcName is called with literal string so independent of whether we have Const or not
         
        If bProfileThis Then
           If Not StrComp(Left$(CodeMod.Lines(LineNum, 1), Len(ProfileProcName)), ProfileProcName, vbTextCompare) = 0 Then
            ' Dim P_ as new Tracer: P_.Start "modname.procname"
              CodeMod.InsertLines LineNum, ProfileProcName & " """ & CodeMod.Name & "." & Procname & """"
           End If
        End If
        ' ProcEndLine will shift down if we insert profiling code lines
        ' move to next line after proc
        LineNum = ProcStartLine + CodeMod.ProcCountLines(Procname, ProcType)
         
      Loop
   End If ' not the Tracer class itself
   
Next ' VBCOMPONENT

End Sub