3
\$\begingroup\$

I wrote this to help manage the code in a bunch of distributed workbooks. Maybe someday I will re-write this as an add-in, but for now, I just needed a way to manage the code without having to manually update every workbook everytime I made a change.

I'm hoping to get some feedback on any major red-flags / things I shouldn't be doing, and if there are any obvious improvements to make. I'm a Mort when it comes to programming, and this is is my first time really messing with VBA extensibility.

Thanks for your time.

ThisWorkbook module:

Option Explicit
Private Sub Workbook_Open()
    'Class Coder programatically updates the code modules
    Dim Coder As Coder
    Set Coder = New Coder
    'Pass the path where the code modules are stored
    Coder.Repository = "X:\CODE MODULES\"
    'Run the procedure that updates the code in the workbook from the central repository
    Coder.GetLatest
    'Desroy object
    Set Coder = Nothing
    
    'do other stuff
End Sub

Class Coder module:

Option Explicit
'Requires reference to "Microsoft Visual Basic for Applications Extensibility"
Const Depricator        As String = "_DEP"
Const wsCodeName        As String = "SheetCodeData"
Private pVerT           As ListObject
Private pCodeWS         As Worksheet
Private pRep            As String
Private pCodeVers       As Scripting.Dictionary

Public Property Let Repository(S As String)
    If Not Right(S, 1) = "\" Then S = S & "\"
    pRep = S
End Property
Public Property Get Repository() As String
    Repository = pRep
End Property

Public Property Get CodeSheet() As Worksheet
    Set CodeSheet = pCodeWS
End Property

Public Property Get VerTable() As ListObject
    Set VerTable = pVerT
End Property

Private Property Get VerHist() As Scripting.Dictionary
    Set VerHist = pCodeVers
End Property

Private Sub Class_Initialize()
    'We are going to read and store some information relative to the _
     procedures in this class.  We'll store what we needin tables on a _
     single worksheet.
    
    'Try to get worksheet with codename that matches WsCodeName
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(ThisWorkbook.VBProject.VBComponents(wsCodeName).Properties("Name").Value)
    On Error GoTo 0
    'if worksheet doesn't exist let's create it
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count), Type:=xlWorksheet)
        With ws
            .Name = "CodeData"
            .Tab.Color = vbRed
            .Visible = xlVeryHidden
            ThisWorkbook.VBProject.VBComponents(.CodeName).Name = wsCodeName
        End With
    End If
    'store the worksheet
    Set pCodeWS = ws
    
    'Try to get the code version history table:
    Const TableName As String = "MacroVersionTable"
    Dim Tbl As ListObject
    On Error Resume Next
    Set Tbl = ws.ListObjects(TableName)
    On Error GoTo 0
    'if table doesn't exist then create it:
    If Tbl Is Nothing Then
        'Get the next free cell in the first row of the target worksheet
        Dim Loc As Range
        Dim Last As Range
        Set Last = ws.Cells.Find("*", ws.Cells(1, 1), , , xlByColumns, xlPrevious)
        Set Loc = ws.Cells(1, Last.Column + 1)
        'Resize so we can have two columns
        Set Loc = Loc.Resize(1, 2)
        'Create the table
        Set Tbl = ws.ListObjects.Add(SourceType:=xlSrcRange, _
                Source:=Loc, xllistobjecthasheaders:=xlNo)
        'Name the columns
        With Tbl
            .Name = TableName
            .ListColumns(1).Name = "CodeModule"
            .ListColumns(2).Name = "Version"
        End With
    End If
    'store the table
    Set pVerT = Tbl
    
    'Store the current version history for access later
    If pCodeVers Is Nothing Then Set pCodeVers = New Scripting.Dictionary
    
    Dim X As Range
    For Each X In Tbl.ListColumns(1).DataBodyRange
        pCodeVers.Add CStr(X), CDate(Tbl.ListColumns(2).DataBodyRange.Cells(X.Row - Tbl.HeaderRowRange.Row, 1))
    Next
        
End Sub

Private Sub Class_Terminate()
    Set pVerT = Nothing
    Set pCodeWS = Nothing
    pRep = vbNullString
End Sub

Public Sub GetLatest(Optional ByRef IgnoreModule As String)
    'VBA struggles with removing and adding a module with the same name _
     within a single procedure, so we'll handle this in two separate procedures
    ImportNew IgnoreModule
    RemoveDepricated
End Sub

Private Function CheckVersion(ByRef ModuleName As String, ByRef LatestVersion As Date) As Long
    'Returns: _
        0 = Current Version _
        1 = Older Version _
        2 = No Record
    If Not VerHist.Exists(ModuleName) Then CheckVersion = 2: Exit Function
    If VerHist(ModuleName) >= LatestVersion Then CheckVersion = 0 Else CheckVersion = 1
End Function

Private Sub ImportNew(Optional ByRef Ignore As String)
    'This sub imports the code modules from the central repository

    'Let's first get the header row of our version table
    Dim TblHeader As Long
    TblHeader = VerTable.HeaderRowRange.Row
    
    'Let's create our VBIDE objects so we can manipulate the code modules
    Dim vbP As VBIDE.VBProject
    Dim vbC As VBIDE.VBComponent
    Set vbP = Application.ThisWorkbook.VBProject
    
    'We 'll use the Microsoft FileSystemObject to access the files in the folder
    Dim fso As Scripting.FileSystemObject
    Dim fsoFolder As Scripting.Folder
    Dim fsoFile As Scripting.File
    Set fso = New Scripting.FileSystemObject
    Set fsoFolder = fso.GetFolder(pRep)
    
    'We'll loop through all the files in the folder, and just update what's needed
    For Each fsoFile In fsoFolder.Files
        Dim FileName As String
        Dim CodeName As String
        Dim FileDate As Date
    
        FileName = fsoFile.ShortName
        CodeName = Left(FileName, InStrRev(FileName, ".") - 1)
        FileDate = fsoFile.DateLastModified

            Select Case CodeName
                Case "Coder"
                'do nothing
                Case Ignore
                'do nothing
                Case Else
                'Check if module exists in our VB Project:
                    Dim LoadIt  As Boolean
                    Dim DepIt   As Boolean
                                   
                    On Error Resume Next
                    Set vbC = vbP.VBComponents(CodeName)
                    On Error GoTo 0
                    
                    'If we don't have this module then we'll want to import it
                    If vbC Is Nothing Then
                        LoadIt = True
                    
                    'If we have the module, let's see if we have the latest version. _
                     if we don't have the latest version, we'll want to import it.
                    ElseIf Not CheckVersion(FileName, FileDate) = 0 Then
                        LoadIt = True
                        If vbC.Type <> 100 Then DepIt = True 'Worksheets are handled differently
                    End If
                    
                    'Rename the module if we flagged it for deprication
                    If DepIt Then vbC.Name = vbC.Name & Depricator

                    If LoadIt Then
                        Select Case vbC.Type
                            Case 100 'Worksheets
                                Dim Dest As VBIDE.CodeModule
                                Set Dest = vbP.VBComponents(CodeName).CodeModule
                                Dest.DeleteLines 1, Dest.CountOfLines 'Erase existing lines
                                Dest.AddFromFile fsoFile.Path 'import new code from file
                                
                                'remove any header info that gets pulled in from the file:
                                Dim OpExLine As Long
                                Dest.Find "Option Explicit", OpExLine, 0, Dest.CountOfDeclarationLines, 99
                                Dest.DeleteLines 1, OpExLine - 1
                    
                            Case Else
                                vbC.Name = vbC.Name & Depricator
                                'Import the new module if needed
                                If LoadIt Then vbP.VBComponents.Import pRep & FileName
                        End Select
                    End If
                        
                    'If we are importing a new file, we want to update our records:
                    If Not VerHist.Exists(FileName) Then
                        VerHist.Add FileName, FileDate
                    Else
                        VerHist(FileName) = FileDate
                    End If
                    
                    'Update the record in excel as well:
                    Dim X As Range
                    On Error Resume Next
                    Set X = VerTable.ListColumns(1).DataBodyRange.Find(FileName)
                    On Error GoTo 0
                    If X Is Nothing Then
                        VerTable.ListRows.Add
                        Set X = VerTable.ListRows(VerTable.ListRows.count).Range.Cells(1, 1)
                        X = FileName
                    End If
                    VerTable.ListColumns(2).DataBodyRange.Cells(X.Row - VerTable.HeaderRowRange.Row, 1) = VerHist(FileName)

                'Reset our variables
                LoadIt = False
                DepIt = False
                Set X = Nothing
            End Select
            
            'Rest our variables
            Set vbC = Nothing
            CodeName = ""
            FileName = ""
    Next

End Sub

Private Sub RemoveDepricated()
    'This sub renmoves the depricated code modules that we previously renamed
    Dim vbP As VBIDE.VBProject
    Dim vbC As VBIDE.VBComponent
    Set vbP = Application.ThisWorkbook.VBProject
    
    For Each vbC In vbP.VBComponents
        If InStr(1, vbC.Name, Depricator) > 0 Then vbP.VBComponents.Remove vbC
    Next

End Sub

Private Sub AddReference(RefName As String, RefDll As String)
    'This procedure adds references to rhe project. It takes two parameters _
     RefName = the reference name as it appears in the add reference dialog _
        i.e. "Microsoft Scripting Runtime" _
     RefDll = the location of the DLL _
        i.e. "C:\Windows\System32\scrrun.dll" _

    Dim VBAEditor As VBIDE.VBE
    Dim vbProj As VBIDE.VBProject
    Dim chkRef As VBIDE.Reference
    Dim BoolExists As Boolean

    Set VBAEditor = Application.VBE
    Set vbProj = ActiveWorkbook.VBProject

    'Check if reference already added to project
    For Each chkRef In vbProj.References
        If chkRef.Name = RefName Then
            BoolExists = True
            GoTo CleanUp
        End If
    Next

    vbProj.References.AddFromFile RefDll

CleanUp:
    'If BoolExists = True Then
        'Debug.print "Reference already exists"
    'Else
        'Debug.print "Reference Added Successfully"
    'End If
    Set chkRef = Nothing
    Set vbProj = Nothing
    Set VBAEditor = Nothing
End Sub
\$\endgroup\$
3
  • 1
    \$\begingroup\$ This is a very very minor nitpick, but is Deprecated, not Depricated. \$\endgroup\$
    – BigBen
    Mar 3, 2022 at 19:40
  • \$\begingroup\$ What does your worksheet look like? You can link a file or better post a markdown table with sample data in case any links die \$\endgroup\$
    – Greedo
    Mar 3, 2022 at 19:59
  • 1
    \$\begingroup\$ The biggest red flag is the trust issues with programmatic access to the VB project. Microsoft blocks these actions for good reason. If your goal is to deploy this to users you will have to defeat the security for each user to allow this to function. Related MS article: support.microsoft.com/en-us/topic/… \$\endgroup\$
    – HackSlash
    Mar 4, 2022 at 17:07

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Browse other questions tagged or ask your own question.