Sample Code


Adding A Module To A Project

This code will add new code module named NewModule to the VBProject of the active workbook. The type of VBComponent is specified by the value of the parameter passed to the Add method.

Public Sub AddModuleToProject() 
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
        
   Set VBProj = ActiveWorkbook.VBProject
   Set VBComp = VBProj.VBComponents.Add(vbext_ct_StdModule)
   VBComp.Name = "NewModule"
End Sub

Adding A Procedure To A Module

This code will add a simple "Hello World" procedure named SayHello to the end of the module named Module1.

Public Sub AddProcedureToModule() 
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Const DQUOTE = """" ' one " character

   Set VBProj = ActiveWorkbook.VBProject
   Set VBComp = VBProj.VBComponents("Module1")
   Set CodeMod = VBComp.CodeModule
        
   With CodeMod
      LineNum = .CountOfLines + 1
      .InsertLines LineNum, "Public Sub SayHello()"
      LineNum = LineNum + 1
      .InsertLines LineNum, " MsgBox " & DQUOTE & "Hello World" & DQUOTE
      LineNum = LineNum + 1
      .InsertLines LineNum, "End Sub"
   End With
End Sub

Creating An Event Procedure

This code will create a Workbook_Open event procedure. When creating an event procedure, you should use the CreateEventProc method so that the correct procedure declaration and parameter list is used.
This code will create the declaration line and the end of procedure line. It returns the line number on which the event procedure begins.

Public Sub CreateEventProcedure() 
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Const DQUOTE = """" ' one " character

   Set VBProj = ActiveWorkbook.VBProject
   Set VBComp = VBProj.VBComponents("ThisWorkbook")
   Set CodeMod = VBComp.CodeModule
        
   With CodeMod
      LineNum = .CreateEventProc("Open", "Workbook")
      LineNum = LineNum + 1
      .InsertLines LineNum, " MsgBox " & DQUOTE & "Hello World" & DQUOTE
   End With
End Sub

Deleting A Module From A Project

This code will delete Module1 from the VBProject. Note that you cannot remove any of the Sheet modules or the ThisWorkbook module.
In general, you cannot delete a module whose Type is vbext_ct_Document.

Public Sub DeleteModule() 
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
    
   Set VBProj = ActiveWorkbook.VBProject
   Set VBComp = VBProj.VBComponents("Module1")
   VBProj.VBComponents.Remove VBComp
End Sub

Deleting A Procedure From A Module

This code will delete the procedure DeleteThisProc from the Module1.
You must specify the procedure type in order to differentiate between Property Get, Property Let, and Property Set procedure, all of which have the same name.

Public Sub DeleteProcedureFromModule() 
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim StartLine As Long
Dim NumLines As Long
Dim ProcName As String
        
   Set VBProj = ActiveWorkbook.VBProject
   Set VBComp = VBProj.VBComponents("Module1")
   Set CodeMod = VBComp.CodeModule
    
   ProcName = "DeleteThisProc"
   With CodeMod
       StartLine = .ProcStartLine(ProcName, vbext_pk_Proc)
       NumLines = .ProcCountLines(ProcName, vbext_pk_Proc)
       .DeleteLines StartLine:=StartLine, Count:=NumLines
   End With
End Sub

Deleting All VBA Code In A Project

This code will delete ALL VBA code in a VBProject.

Public Sub DeleteAllVBACode() 
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
        
   Set VBProj = ActiveWorkbook.VBProject
        
   For Each VBComp In VBProj.VBComponents
      If (VBComp.Type = vbext_ct_Document) Then
         Set CodeMod = VBComp.CodeModule
         CodeMod.DeleteLines 1, .CountOfLines
      Else
         VBProj.VBComponents.Remove VBComp
      End If
   Next VBComp
End Sub

Exporting A VBComponent Code Module To A Text File

You can export an existing VBComponent CodeModule to a text file.
If FileName is missing, the code will be exported to a file with the same name as the VBComponent followed by the appropriate extension.
This can be useful if you are archiving modules to create a library of useful module to be used in other projects.

Public Function ExportVBComponent(ByVal VBComp As VBIDE.VBComponent, _ 
                                  ByVal FolderName As String, _
                         Optional ByVal FileName As String, _
                         Optional ByVal OverwriteExisting As Boolean = True) As Boolean

Dim Extension As String
Dim FName As String

    Extension = GetFileExtension(VBComp:=VBComp)
    If Trim(FileName) = vbNullString Then
        FName = VBComp.Name & Extension
    Else
        FName = FileName
        If InStr(1, FName, ".", vbBinaryCompare) = 0 Then
            FName = FName & Extension
        End If
    End If
    
    If StrComp(Right(FolderName, 1), "\", vbBinaryCompare) = 0 Then
        FName = FolderName & FName
    Else
        FName = FolderName & "\" & FName
    End If
    
    If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
        If OverwriteExisting = True Then
            Kill FName
        Else
            ExportVBComponent = False
            Exit Function
        End If
    End If
    
    VBComp.Export FileName:=FName
    ExportVBComponent = True
End Function
    
Public Function GetFileExtension(ByVal VBComp As VBIDE.VBComponent) As String
    Select Case VBComp.Type
        Case vbext_ct_ClassModule
            GetFileExtension = ".cls"
        Case vbext_ct_Document
            GetFileExtension = ".cls"
        Case vbext_ct_MSForm
            GetFileExtension = ".frm"
        Case vbext_ct_StdModule
            GetFileExtension = ".bas"
        Case Else
            GetFileExtension = ".bas"
    End Select
End Function

Listing All Modules In A Project

This code will list all the modules and their types in the workbook, starting the listing in cell A1.

Public Sub ListModules() 
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim WS As Worksheet
Dim Rng As Range
        
   Set VBProj = ActiveWorkbook.VBProject
   Set WS = ActiveWorkbook.Worksheets("Sheet1")
   Set Rng = WS.Range("A1")
        
   For Each VBComp In VBProj.VBComponents
      Rng(1, 1).Value = VBComp.Name
      Rng(1, 2).Value = ComponentTypeToString(VBComp.Type)
      Set Rng = Rng(2, 1)
   Next VBComp
End Sub
    
Public Function ComponentTypeToString(ByVal ComponentType As VBIDE.vbext_ComponentType) As String
   Select Case ComponentType
      Case vbext_ct_ActiveXDesigner
          ComponentTypeToString = "ActiveX Designer"
      Case vbext_ct_ClassModule
          ComponentTypeToString = "Class Module"
      Case vbext_ct_Document
          ComponentTypeToString = "Document Module"
      Case vbext_ct_MSForm
          ComponentTypeToString = "UserForm"
      Case vbext_ct_StdModule
          ComponentTypeToString = "Code Module"
      Case Else
          ComponentTypeToString = "Unknown Type: " & CStr(ComponentType)
   End Select
End Function

Listing All Procedures In A Module

This code will list all the procedures in Module1, beginning the listing in cell A1.

Public Sub ListProcedures() 
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Dim NumLines As Long
Dim WS As Worksheet
Dim Rng As Range
Dim ProcName As String
Dim ProcKind As VBIDE.vbext_ProcKind
        
   Set VBProj = ActiveWorkbook.VBProject
   Set VBComp = VBProj.VBComponents("Module1")
   Set CodeMod = VBComp.CodeModule
        
   Set WS = ActiveWorkbook.Worksheets("Sheet1")
   Set Rng = WS.Range("A1")
        
   With CodeMod
      LineNum = .CountOfDeclarationLines + 1
      ProcName = .ProcOfLine(LineNum, ProcKind)
      Do Until LineNum >= .CountOfLines
          Rng(1, 1).Value = ProcName
          Rng(1, 2).Value = ProcKindString(ProcKind)
          Set Rng = Rng(2, 1)
          LineNum = LineNum + .ProcCountLines(ProcName, ProcKind) + 1
          ProcName = .ProcOfLine(LineNum, ProcKind)
      Loop
   End With
End Sub
    
Public Function ProcKindString(ByVal ProcKind As VBIDE.vbext_ProcKind) As String
   Select Case ProcKind
      Case vbext_pk_Get
          ProcKindString = "Property Get"
      Case vbext_pk_Let
          ProcKindString = "Property Let"
      Case vbext_pk_Set
          ProcKindString = "Property Set"
      Case vbext_pk_Proc
          ProcKindString = "Sub Or Function"
      Case Else
          ProcKindString = "Unknown Type: " & CStr(ProcKind)
   End Select
End Function

Searching For Text In A Module

Find and Replace



Testing If A VBComponent Exists

This code will return True or False indicating whether the VBComponent named by VBCompName exists in the project referenced by VBProj. If VBProj is omitted, the VBProject of the ActiveWorkbook is used.

Public Function VBComponentExists(ByVal VBCompName As String, _ 
                         Optional ByVal VBProj As VBIDE.VBProject = Nothing) As Boolean

Dim VBP As VBIDE.VBProject

   If VBProj Is Nothing Then
      Set VBP = ActiveWorkbook.VBProject
   Else
      Set VBP = VBProj
   End If

   On Error Resume Next
   VBComponentExists = CBool(Len(VBP.VBComponents(VBCompName).Name))
    
End Function

Total Code Lines In A Component

This function will return the total code lines in a VBComponent.
It ignores blank lines and comment lines. It will return -1 if the project is locked.

Public Function TotalCodeLinesInVBComponent(ByVal VBComp As VBIDE.VBComponent) As Long 
Dim N As Long
Dim S As String
Dim LineCount As Long
        
   If VBComp.Collection.Parent.Protection = vbext_pp_locked Then
      TotalCodeLinesInVBComponent = -1
      Exit Function
   End If
        
   With VBComp.CodeModule
      For N = 1 To .CountOfLines
         S = .Lines(N, 1)
         If Trim(S) = vbNullString Then
' blank line, skip it
         ElseIf Left(Trim(S), 1) = "'" Then
' comment line, skip it
         Else
            LineCount = LineCount + 1
         End If
      Next N
   End With

   TotalCodeLinesInVBComponent = LineCount
End Function

Total Lines In A Project

This code will return the count of lines in all components of the project referenced by VBProj.
If VBProj is omitted, the VBProject of the ActiveWorkbook is used. The function will return -1 if the project is locked.

Public Function TotalLinesInProject(Optional VBProj As VBIDE.VBProject = Nothing) As Long 
    
Dim VBP As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim LineCount As Long
        
   If VBProj Is Nothing Then
      Set VBP = ActiveWorkbook.VBProject
   Else
      Set VBP = VBProj
   End If
        
   If VBP.Protection = vbext_pp_locked Then
      TotalLinesInProject = -1
      Exit Function
   End If
        
   For Each VBComp In VBP.VBComponents
      LineCount = LineCount + VBComp.CodeModule.CountOfLines
   Next VBComp
        
   TotalLinesInProject = LineCount
End Function

Total Code Lines In A Component

This function will return the total number of code lines in a VBComponent.
It ignores blank lines and comment lines. It will return -1 if the project is locked.

Public Function TotalCodeLinesInVBComponent(VBComp As VBIDE.VBComponent) As Long 
Dim N As Long
Dim S As String
Dim LineCount As Long
        
   If VBComp.Collection.Parent.Protection = vbext_pp_locked Then
      TotalCodeLinesInVBComponent = -1
      Exit Function
   End If
        
   With VBComp.CodeModule
      For N = 1 To .CountOfLines
         S = .Lines(N, 1)
         If Trim(S) = vbNullString Then
' blank line, skip it
         ElseIf Left(Trim(S), 1) = "'" Then
' comment line, skip it
         Else
            LineCount = LineCount + 1
         End If
      Next N
   End With

   TotalCodeLinesInVBComponent = LineCount
End Function

Total Code Lines In A Project

This function will return the total number of code lines in all the components of a VBProject.
It ignores blank lines and comment lines. It will return -1 if the project is locked.

Public Function TotalCodeLinesInProject(ByVal VBProj As VBIDE.VBProject) As Long 
Dim VBComp As VBIDE.VBComponent
Dim LineCount As Long

   If VBProj.Protection = vbext_pp_locked Then
      TotalCodeLinesInProject = -1
      Exit Function
   End If

   For Each VBComp In VBProj.VBComponents
      LineCount = LineCount + TotalCodeLinesInVBComponent(VBComp)
   Next VBComp
        
   TotalCodeLinesInProject = LineCount
End Function

Procnames Function

Function to return the names of Procedures in a given module

Public Function ProcNames(ByVal sModuleName As String) As String() 
Dim lngSLine As Long
Dim vbCodeMod As CodeModule
Dim intPCount As Integer
Dim pnamearray() As String

    Set vbCodeMod = ThisWorkbook.VBProject.VBComponents(sModuleName).CodeModule

    With vbCodeMod
        lngSLine = .CountOfDeclarationLines + 1
        Do Until lngSLine >= .CountOfLines
            intPCount = intPCount + 1
            ReDim Preserve pnamearray(intPCount)
            pnamearray(intPCount) = .ProcOfLine(lngSLine, vbext_pk_Proc)
            lngSLine = lngSLine + .ProcCountLines(.ProcOfLine(lngSLine, vbext_pk_Proc), vbext_pk_Proc)
        Loop
    End With

    ProcNames = pnamearray()
End Function

ModExist Function

This function test to see if a given VBA module exists in the current project.

Public Function ModExist(ByVal sModuleName As String) As Boolean 
Dim intVBCcnt As Integer
Dim intVBDcnt As Integer
Dim intLC1 As Integer

    intVBCcnt = ThisWorkbook.VBProject.VBComponents.Count
    intVBDcnt = 0

    For intLC1 = 1 To intVBCcnt
        If ThisWorkbook.VBProject.VBComponents(intLC1).Type = vbext_ct_StdModule Then
            If ThisWorkbook.VBProject.VBComponents(intLC1).Name = sModuleName Then
                ModExist = True
                GoTo Exit_ModExist
            End If
        End If
    Next intLC1

    ModExist = False
Exit_ModExist:
End Function

Really Bad Code

This code has not been validated - please don't use


Copy A Module From One Project To Another

There is no direct way to copy a module from one project to another.
To accomplish this task, you must export the module from the Source VBProject and then import that file into the Destination VBProject.
The code below will do this. The function declaration is:

Function CopyModule(ModuleName As String, _ 
    FromVBProject As VBIDE.VBProject, _
    ToVBProject As VBIDE.VBProject, _
    OverwriteExisting As Boolean) As Boolean

  • ModuleName is the name of the module you want to copy from one project to another.

  • FromVBProject is the VBProject that contains the module to be copied. This is the source VBProject.

  • ToVBProject is the VBProject in to which the module is to be copied. This is the destination VBProject.

  • OverwriteExisting indicates what to do if ModuleName already exists in the ToVBProject. If this is True the existing VBComponent will be removed from the ToVBProject.

If this is False and the VBComponent already exists, the function does nothing and returns False.
The function returns True if successful or False is an error occurs. The function will return False if any of the following are true:


FromVBProject is nothing.
ToVBProject is nothing.
ModuleName is blank.
FromVBProject is locked.
ToVBProject is locked.
ModuleName does not exist in FromVBProject.
ModuleName exists in ToVBProject and OverwriteExisting is False.

Function CopyModule(ModuleName As String, _ 
    FromVBProject As VBIDE.VBProject, _
    ToVBProject As VBIDE.VBProject, _
    OverwriteExisting As Boolean) As Boolean
    Dim VBComp As VBIDE.VBComponent
    Dim FName As String
    
    If FromVBProject Is Nothing Then
        CopyModule = False
        Exit Function
    End If
    
    If Trim(ModuleName) = vbNullString Then
        CopyModule = False
        Exit Function
    End If
    
    If ToVBProject Is Nothing Then
        CopyModule = False
        Exit Function
    End If
    
    If FromVBProject.Protection = vbext_pp_locked Then
        CopyModule = False
        Exit Function
    End If
    
    If ToVBProject.Protection = vbext_pp_locked Then
        CopyModule = False
        Exit Function
    End If
    
    On Error Resume Next
    Set VBComp = FromVBProject.VBComponents(ModuleName)
    If Err.Number <> 0 Then
        CopyModule = False
        Exit Function
    End If
    
    FName = Environ("Temp") & "\" & ModuleName & ".bas"
    If OverwriteExisting = True Then
        If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
            Err.Clear
            Kill FName
            If Err.Number <> 0 Then
                CopyModule = False
                Exit Function
            End If
        End If
        With ToVBProject.VBComponents
            .Remove .Item(ModuleName)
        End With
    Else
        Err.Clear
        Set VBComp = ToVBProject.VBComponents(ModuleName)
        If Err.Number <> 0 Then
            If Err.Number = 9 Then
' module doesn't exist. ignore error.
            Else
' other error. get out with return value of False
                CopyModule = False
                Exit Function
            End If
        End If
    End If
    
    FromVBProject.VBComponents(ModuleName).Export Filename:=FName
    ToVBProject.VBComponents.Import Filename:=FName
    Kill FName
    CopyModule = True
End Function

Eliminating Screen Flicker During VBProject Code

When you used the Extensibility code, the VBA Editor window will flicker. This can be reduced with the code:
Application.VBE.MainWindow.Visible = False
This will hide the VBE window, but you may still see it flicker. To prevent this, you must use the LockWindowUpdate Windows API function.

    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ 
        (ByVal ClassName As String, ByVal WindowName As String) As Long
    
    Private Declare Function LockWindowUpdate Lib "user32" _
        (ByVal hWndLock As Long) As Long

    Sub EliminateScreenFlicker()
        Dim VBEHwnd As Long
        
        On Error GoTo ErrH:
        
        Application.VBE.MainWindow.Visible = False
        
        VBEHwnd = FindWindow("wndclass_desked_gsk", _
            Application.VBE.MainWindow.Caption)
        
        If VBEHwnd Then
            LockWindowUpdate VBEHwnd
        End If
        
'''''''''''''''''''''''''
' your code here
'''''''''''''''''''''''''
        
        Application.VBE.MainWindow.Visible = False
    ErrH:
        LockWindowUpdate 0&
    End Sub

General Infomation About A Procedure

The code below returns the following information about a procedure in a module, loaded into the ProcInfo Type.
The function ProcedureInfo takes as input then name of the procedure, a VBIDE.vbext_ProcKind procedure type, and a reference to the CodeModule object containing the procedure.

    Public Enum ProcScope 
        ScopePrivate = 1
        ScopePublic = 2
        ScopeFriend = 3
        ScopeDefault = 4
    End Enum
    
    Public Enum LineSplits
        LineSplitRemove = 0
        LineSplitKeep = 1
        LineSplitConvert = 2
    End Enum
    
    Public Type ProcInfo
        ProcName As String
        ProcKind As VBIDE.vbext_ProcKind
        ProcStartLine As Long
        ProcBodyLine As Long
        ProcCountLines As Long
        ProcScope As ProcScope
        ProcDeclaration As String
    End Type

    Function ProcedureInfo(ProcName As String, ProcKind As VBIDE.vbext_ProcKind, _
        CodeMod As VBIDE.CodeModule) As ProcInfo
    
        Dim PInfo As ProcInfo
        Dim BodyLine As Long
        Dim Declaration As String
        Dim FirstLine As String
        
        
        BodyLine = CodeMod.ProcStartLine(ProcName, ProcKind)
        If BodyLine > 0 Then
            With CodeMod
                PInfo.ProcName = ProcName
                PInfo.ProcKind = ProcKind
                PInfo.ProcBodyLine = .ProcBodyLine(ProcName, ProcKind)
                PInfo.ProcCountLines = .ProcCountLines(ProcName, ProcKind)
                PInfo.ProcStartLine = .ProcStartLine(ProcName, ProcKind)
                
                FirstLine = .Lines(PInfo.ProcBodyLine, 1)
                If StrComp(Left(FirstLine, Len("Public")), "Public", vbBinaryCompare) = 0 Then
                    PInfo.ProcScope = ScopePublic
                ElseIf StrComp(Left(FirstLine, Len("Private")), "Private", vbBinaryCompare) = 0 Then
                    PInfo.ProcScope = ScopePrivate
                ElseIf StrComp(Left(FirstLine, Len("Friend")), "Friend", vbBinaryCompare) = 0 Then
                    PInfo.ProcScope = ScopeFriend
                Else
                    PInfo.ProcScope = ScopeDefault
                End If
                PInfo.ProcDeclaration = GetProcedureDeclaration(CodeMod, ProcName, ProcKind, LineSplitKeep)
            End With
        End If
        
        ProcedureInfo = PInfo
    
    End Function
    
    
    Public Function GetProcedureDeclaration(CodeMod As VBIDE.CodeModule, _
        ProcName As String, ProcKind As VBIDE.vbext_ProcKind, _
        Optional LineSplitBehavior As LineSplits = LineSplitRemove)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetProcedureDeclaration
' This return the procedure declaration of ProcName in CodeMod. The LineSplitBehavior
' determines what to do with procedure declaration that span more than one line using
' the "_" line continuation character. If LineSplitBehavior is LineSplitRemove, the
' entire procedure declaration is converted to a single line of text. If
' LineSplitBehavior is LineSplitKeep the "_" characters are retained and the
' declaration is split with vbNewLine into multiple lines. If LineSplitBehavior is
' LineSplitConvert, the "_" characters are removed and replaced with vbNewLine.
' The function returns vbNullString if the procedure could not be found.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Dim LineNum As Long
        Dim S As String
        Dim Declaration As String
        
        On Error Resume Next
        LineNum = CodeMod.ProcBodyLine(ProcName, ProcKind)
        If Err.Number <> 0 Then
            Exit Function
        End If
        S = CodeMod.Lines(LineNum, 1)
        Do While Right(S, 1) = "_"
            Select Case True
                Case LineSplitBehavior = LineSplitConvert
                    S = Left(S, Len(S) - 1) & vbNewLine
                Case LineSplitBehavior = LineSplitKeep
                    S = S & vbNewLine
                Case LineSplitBehavior = LineSplitRemove
                    S = Left(S, Len(S) - 1) & " "
            End Select
            Declaration = Declaration & S
            LineNum = LineNum + 1
            S = CodeMod.Lines(LineNum, 1)
        Loop
        Declaration = SingleSpace(Declaration & S)
        GetProcedureDeclaration = Declaration
        
    
    End Function
    
    Private Function SingleSpace(ByVal Text As String) As String
        Dim Pos As String
        Pos = InStr(1, Text, Space(2), vbBinaryCompare)
        Do Until Pos = 0
            Text = Replace(Text, Space(2), Space(1))
            Pos = InStr(1, Text, Space(2), vbBinaryCompare)
        Loop
        SingleSpace = Text
    End Function

You can call the ProcedureInfo function using code like the following:


    Sub ShowProcedureInfo() 
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.CodeModule
        Dim CompName As String
        Dim ProcName As String
        Dim ProcKind As VBIDE.vbext_ProcKind
        Dim PInfo As ProcInfo
        
        CompName = "modVBECode"
        ProcName = "ProcedureInfo"
        ProcKind = vbext_pk_Proc
        
        Set VBProj = ActiveWorkbook.VBProject
        Set VBComp = VBProj.VBComponents(CompName)
        Set CodeMod = VBComp.CodeModule
        
        PInfo = ProcedureInfo(ProcName, ProcKind, CodeMod)
        
        Debug.Print "ProcName: " & PInfo.ProcName
        Debug.Print "ProcKind: " & CStr(PInfo.ProcKind)
        Debug.Print "ProcStartLine: " & CStr(PInfo.ProcStartLine)
        Debug.Print "ProcBodyLine: " & CStr(PInfo.ProcBodyLine)
        Debug.Print "ProcCountLines: " & CStr(PInfo.ProcCountLines)
        Debug.Print "ProcScope: " & CStr(PInfo.ProcScope)
        Debug.Print "ProcDeclaration: " & PInfo.ProcDeclaration
    End Sub

Find the name of a VBComponent that contains a specified procedure

The problem - you want to programatically obtain the name of the
VBComponent that contains a specified procedure. Stephen's solution
was to look for unique strings, since the VBIDE object model does
not provide functionality for doing this directly.

Sub TestIt() 
MsgBox fnThisVBComponent(ThisWorkbook, "This Unique String").Name & ", " & _
       fnThisProcedureName(ThisWorkbook, "Another Unique String")

End Sub

Function fnThisVBComponent(oBk As Workbook, sUniqueString As String) As VBComponent 
Dim oVBC As VBComponent

For Each oVBC In oBk.VBProject.VBComponents
    With oVBC.CodeModule

        If .Find(sUniqueString, 1, 1, .CountOfLines, 1000, True, _
True, False) Then

            Set fnThisVBComponent = oVBC
            Exit For
        End If
    End With
Next

End Function

Function fnThisProcedureName(oBk As Workbook, sUniqueString As String) As String 
Dim oVBC As VBComponent
Dim lStart As Long, sProcName As String, vaProcs As Variant,
vProcType As Variant

'Specify the row number of where to start the find. This is set by
'the Find method to give the (starting) line number where the text
'was found. lStart = 1

For Each oVBC In oBk.VBProject.VBComponents

    With oVBC.CodeModule

        If .Find(sUniqueString, lStart, 1, .CountOfLines, 1000, True, _
True, False) Then

            vaProcs = Array(vbext_pk_Proc, vbext_pk_Get, vbext_pk_Let, _
    vbext_pk_Set)

            For Each vProcType In vaProcs
                sProcName = .ProcOfLine(lStart, CLng(vProcType))

                If sProcName <> "" Then
                    fnThisProcedureName = sProcName
                    Exit For
                End If
            Next
            Exit For
        End If
    End With
Next
End Function

This procedure contains VBA code to add to your existing VBA code --
basically, it puts one statement at the beginning of each procedure in every
module (class modules and event procedures not included). This statement is
a call to a routine (which YOU need to write) and passes the sub/function
name. For example...


Before:

Sub ABC() 
   Dim i as Integer
   For each x in sheets
   Next
End Sub

Sub xyz()
End Sub

After:

Sub ABC() 
MyProc "ABC"
   Dim i as Integer
   For each x in sheets
   Next
End Sub

Sub xyz()
MyProc "xyz"
End Sub


© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext