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
