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.
The complete code is shown below:


Function CopyModule(ModuleName As String, _ 
    FromVBProject As VBIDE.VBProject, _
    ToVBProject As VBIDE.VBProject, _
    OverwriteExisting As Boolean) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CopyModule
' This function copies a module from one VBProject to
' another. It returns True if successful or False
' if an error occurs.
'
' Parameters:
' --------------------------------
' FromVBProject The VBProject that contains the module
' to be copied.
'
' ToVBProject The VBProject into which the module is
' to be copied.
'
' ModuleName The name of the module to copy.
'
' OverwriteExisting If True, the VBComponent named ModuleName
' in ToVBProject will be removed before
' importing the module. If False and
' a VBComponent named ModuleName exists
' in ToVBProject, the code will return
' False.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    Dim VBComp As VBIDE.VBComponent
    Dim FName As String
    
'''''''''''''''''''''''''''''''''''''''''''''
' Do some housekeeping validation.
'''''''''''''''''''''''''''''''''''''''''''''
    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 is the name of the temporary file to be
' used in the Export/Import code.
''''''''''''''''''''''''''''''''''''''''''''''''''''
    FName = Environ("Temp") & "\" & ModuleName & ".bas"
    If OverwriteExisting = True Then
''''''''''''''''''''''''''''''''''''''
' If OverwriteExisting is True, Kill
' the existing temp file and remove
' the existing VBComponent from the
' ToVBProject.
''''''''''''''''''''''''''''''''''''''
        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
'''''''''''''''''''''''''''''''''''''''''
' OverwriteExisting is False. If there is
' already a VBComponent named ModuleName,
' exit with a return code of False.
''''''''''''''''''''''''''''''''''''''''''
        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
    
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Do the Export and Import operation using FName
' and then Kill FName.
''''''''''''''''''''''''''''''''''''''''''''''''''''
    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

'Loop through the VBComponents in the given workbook's VBProject
For Each oVBC In oBk.VBProject.VBComponents

'Using it's code module
    With oVBC.CodeModule

'See if we can find the unique string
        If .Find(sUniqueString, 1, 1, .CountOfLines, 1000, True, _
True, False) Then

'Found it, so return the VBComponent where it was found
            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

'Loop through the VBComponents in the given workbook's VBProject
For Each oVBC In oBk.VBProject.VBComponents

'Using it's code module
    With oVBC.CodeModule

'See if we can find the unique string
        If .Find(sUniqueString, lStart, 1, .CountOfLines, 1000, True, _
True, False) Then

'We found it, so make an array of the available procedure
'types to check for

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

'Loop throguh the procedure types
            For Each vProcType In vaProcs

'Get the name of the procedure containing the line we
'found above
                sProcName = .ProcOfLine(lStart, CLng(vProcType))

'Did we get a procedure name?
                If sProcName <> "" Then

'We did, so return it
                    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

Notice that afterwards, there's a new line immediately after the sub. It
calls MyProc (this is changeable) and passes the name of the procedure it's
in. You can use MyProc to trace flow, track the time, etc -- you can get
creative here!


There are 2 main routines: Addit, and Deleteit. Running Addit will insert
the one-liner, running Deleteit will remove this one-liner. The code is
inserted into the active workbook.


The first line inside the VBE for AddALine.xls is:


Public Const TheProcName As String = "MyProc" '============CHANGE THIS LINE


and whatever you change "MyProc" to will be the routine called inside each
procedure of your code.




Public Const TheProcName As String = "MyProc" '===============CHANGE THIS LINE  
Sub Addit()
'===========================
'RUN THIS CODE TO INSERT THE LINE INTO THE ACTIVE WORKBOOK's CODE
'===========================
    AddALine
    MsgBox "Done....Don't forget to write procedure " & _
TheProcName & "!", vbExclamation
End Sub
Sub Deleteit()
'===========================
'RUN THIS CODE TO DELETE THE LINE
'===========================
    DelALine
    MsgBox TheProcName & " has been deleted from each procedure."
End Sub
Sub AddALine()
Dim ProcName As String, ProcNames() As String, Boo As Boolean
Dim LngR As Long, TheLine As Long, LngI As Long
    Set VBP = ActiveWorkbook.VBProject
    nocomponents = VBP.VBComponents.Count
    On Error Resume Next
    For i = 1 To nocomponents
        If VBP.VBComponents(i).Type = 1 Then 'module
            With VBP.VBComponents(i).CodeModule
                If .Name = "ModInserter" Then GoTo NextOne
                col = .CountOfLines
                codl = .CountOfDeclarationLines
                ProcName = .ProcOfLine(codl + 1, LngR)
                If ProcName = "" Then GoTo NextOne
                If LngR <> 0 Then GoTo NextOne
                TheLine = .ProcBodyLine(ProcName, vbext_pk_Proc)
                thetext = .Lines(TheLine, 1)
                If Right(thetext, 1) = "_" Then j = 2 Else j = 1
                .InsertLines TheLine + j, TheProcName & """" & _
ProcName & """"
                LngI = codl + 1
                col = col + 1
2
                If LngI > col Then GoTo 1
                If ProcName <> .ProcOfLine(LngI, LngR) Then
                    ProcName = .ProcOfLine(LngI, LngR)
                    If LngR <> 0 Then GoTo 3
                    TheLine = .ProcBodyLine(ProcName, vbext_pk_Proc)
                    thetext = .Lines(TheLine, 1)
                    If Right(thetext, 1) = "_" Then j = 2 Else j = 1
                    .InsertLines TheLine + j, TheProcName & """" & _
    ProcName & """"
                    col = col + 1
                End If
3
                LngI = LngI + 1
                GoTo 2
1
                
            End With
        End If
NextOne:
    Next
End Sub
Sub DelALine()
Dim ProcName As String, ProcNames() As String, Boo As Boolean
Dim LngR As Long, TheLine As Integer, LngI As Integer
    If MsgBox("Are you sure you want to delete " & TheProcName & _
    " from each procedure?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
    Set VBP = ActiveWorkbook.VBProject
    nocomponents = VBP.VBComponents.Count
    On Error Resume Next
    For i = 1 To nocomponents
        If VBP.VBComponents(i).Type = 1 Then 'module
            With VBP.VBComponents(i).CodeModule
                If .Name = "ModInserter" Then GoTo NextOne
                col = .CountOfLines
                codl = .CountOfDeclarationLines
                ProcName = .ProcOfLine(codl + 1, LngR)
                If ProcName = "" Then GoTo NextOne
                If LngR <> 0 Then GoTo NextOne
                TheLine = .ProcBodyLine(ProcName, vbext_pk_Proc)
                thetext = .Lines(TheLine, 1)
                If Right(thetext, 1) = "_" Then j = 2 Else j = 1
                If Left(.Lines(TheLine + j, 1), 5) <> Left(TheProcName, 5) Then
' MsgBox TheProcName & " not found in procedure """ & _
ProcName & """... ignoring"
                    GoTo 22
                End If
                .DeleteLines TheLine + j, 1
0.916666666666667
                LngI = codl + 1
2
                If LngI > col Then GoTo 1
                If ProcName <> .ProcOfLine(LngI, LngR) Then
                    ProcName = .ProcOfLine(LngI, LngR)
                    If LngR <> 0 Then GoTo 3
                    If ProcName = "" Then GoTo 3
                    TheLine = .ProcBodyLine(ProcName, vbext_pk_Proc)
                    thetext = .Lines(TheLine, 1)
                    If Right(thetext, 1) = "_" Then j = 2 Else j = 1
                    If Left(.Lines(TheLine + j, 1), 5) <> _
    Left(TheProcName, 5) Then
' MsgBox TheProcName & " not found in procedure """ & _
    ProcName & """... ignoring"
                        GoTo 3
                    End If
                    .DeleteLines TheLine + j, 1
                End If
3
                LngI = LngI + 1
                GoTo 2
1
                
            End With
        End If
NextOne:
    Next
End Sub


Sub Showcode()
    MsgBox "Before running ""Addit"", activate the workbook whose code " & _
    "this routine will update."
    MsgBox "Change ""TheProcName"" to the name of the procedure you want " & _
    "to run for each sub."
    Application.SendKeys "{up}{up}"
    Application.Goto "Addit"
End Sub


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