Context
Me and my team which I'm part of, for most of the time code in Excel VBA. Writing code in it self is pretty enjoyable, but combining our work in a shared repository is pretty painful. The ease our pain of combining/merging binary files, we have decided to help ourselves and create the Source Code Manager module.
Key features:
- User, should be able to export code modules from the Workbook into any location
- User, should be able to import code modules from any location back to Workbook.
Today, I would like from all of you to investigate the former.
Note: if you want to export your code, might have to select Trust access to the VBA project object model in the Developer Macro Settings (File - Options - Trust Center - Trust Center Settings). Otherwise, code will not be exported!
Note2: Everything, which is related to code management, I will try purposefully keep in one module to make it as shareable as possible. Sometime, I will intentionally break a OO principles like creating a new class and moving to it a set of closely related functionalities.
If anything needs an explanation, let me know. This might be a good indication that a piece which I wrote is in a 'not easy to follow' manner, which I'm actively trying to avoid!
Dependencies
To start working with this code you need to add following references to your VB Project
- Microsoft Scripting Runtime
- Microsoft Visual Basic for Application Extensibility 5.3
- Microsoft ActiveX Data Object 6.1 Library
This project requires also additional modules which can be found in External modules
- ArrayH
- Exception
- Tools
Client code
In it's simplest form, you have to call one method SourceControlH.ExportProjectComponents
which requires two parameters, source from which components will be exported (of type Workbook
) and location, where components will be stored (of type String
).
Public Sub Start()
SourceControlH.ExportProjectComponents ThisWorkbook, ThisWorkbook.Path & "\src"
End Sub
The following code presents how do I use SourceControlH
module with the Workbook_AfterSave
event which lets me to export the entire VbProject
when it is saved.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim ExportFolder As String
ExportFolder = ThisWorkbook.Path & "\src"
If Fso.FolderExists(ExportFolder) = False Then
Fso.CreateFolder ExportFolder
End If
SourceControlH.ExportProjectComponents ThisWorkbook, ExportFolder
End Sub
Under the hood
This section will present the actual code which does all the magic.
SourceControlH.bas
Option Explicit
'@Folder("Helper")
Private Const ModuleName As String = "SourceControlH"
' Path to the folder where components will be saved.
Private pExportFolderPath As String
' Indicates if empty components should be exported or not.
Private pExportEmptyComponents As Boolean
Public Property Get ExportEmptyComponents() As Boolean
ExportEmptyComponents = pExportEmptyComponents
End Property
Public Property Let ExportEmptyComponents(ByVal Value As Boolean)
pExportEmptyComponents = Value
End Property
' Exports and saves project's components, from Source workbook
' to the location which is specified in Path argument.
' If Source.VBProject is protected, throw an InvalidOperationException.
' If target path does not exists or if path does not points to a folder,
' throw an DirectoryNotFoundException.
Public Sub ExportProjectComponents(ByVal Source As Workbook, ByVal Path As String)
Const MethodName = "ExportProjectComponents"
If Source.VBProject.Protection = vbext_pp_locked Then
Exception.InvalidOperationException "Source.VBProject.Protection", _
"The VBA project, in this workbook is protected " & _
"therefor, it is not possible to export the components. " & _
"Unlock your VBA project and try again. " & ModuleName & "." & MethodName
End If
If Tools.Fso.FolderExists(Path) = False Then
Exception.DirectoryNotFoundException "Path", ModuleName & "." & MethodName
End If
pExportFolderPath = NormalizePath(Path)
Dim Cmp As VBComponent
For Each Cmp In GetExportableComponents(Source.VBProject.VBComponents)
ExportComponent Cmp
Next Cmp
End Sub
Private Function GetExportableComponents(ByVal Source As VBIDE.VBComponents) As Collection '<VbComponents>
Dim Output As New Collection
Dim Cmp As VBIDE.VBComponent
For Each Cmp In Source
If IsExportable(Cmp) Then
Output.Add Cmp
End If
Next Cmp
Set GetExportableComponents = Output
Set Cmp = Nothing
Set Output = Nothing
End Function
Private Function IsExportable(ByVal Component As VBIDE.VBComponent) As Boolean
' Check if component is on the list of exportable components.
If ArrayH.Exists(Component.Type, ExportableComponentsTypes) = False Then
IsExportable = False
Exit Function
End If
If IsComponentEmpty(Component) = False Then
IsExportable = True
Exit Function
End If
If pExportEmptyComponents = True Then
IsExportable = True
Exit Function
End If
IsExportable = False
End Function
Private Property Get ExportableComponentsTypes() As Variant
ExportableComponentsTypes = Array(vbext_ct_ClassModule, vbext_ct_MSForm, vbext_ct_StdModule, vbext_ct_Document)
End Property
' Indicates if component is empty by checking number of code lines.
' Files, which contains just Option Explicit will be counted as empty.
Private Function IsComponentEmpty(ByVal Source As VBIDE.VBComponent) As Boolean
If Source.CodeModule.CountOfLines < 2 Then
IsComponentEmpty = True
ElseIf Source.CodeModule.CountOfLines = 2 Then
Dim Ln1 As String: Ln1 = Source.CodeModule.Lines(1, 1)
Dim Ln2 As String: Ln2 = Source.CodeModule.Lines(2, 1)
IsComponentEmpty = (VBA.LCase$(Ln1) = "option explicit" And Ln2 = vbNullString)
Else
IsComponentEmpty = False
End If
End Function
Private Sub ExportComponent(ByVal Component As VBIDE.VBComponent)
' Full name means - name of the component with an extension.
Dim FullName As String: FullName = GetComponentFullName(Component)
Dim ExportPath As String: ExportPath = pExportFolderPath & FullName
Component.Export ExportPath
End Sub
' To avoid problems with saving components, add backslash
' at the end of folder path.
Private Function NormalizePath(ByVal Path As String) As String
NormalizePath = Path & IIf(Path Like "*\", vbNullString, "\")
End Function
Private Property Get ComponentTypeToExtension() As Dictionary
Dim Output As New Dictionary
With Output
.Add vbext_ct_ClassModule, "cls"
.Add vbext_ct_MSForm, "frm"
.Add vbext_ct_StdModule, "bas"
.Add vbext_ct_Document, "doccls"
.Add vbext_ct_ActiveXDesigner, "ocx"
End With
Set ComponentTypeToExtension = Output
End Property
Private Function GetComponentFullName(ByVal Component As VBIDE.VBComponent) As String
GetComponentFullName = Component.Name & "." & ComponentTypeToExtension.Item(Component.Type)
End Function
External modules
Modules, with code, which are used by SourceControlH
module. These has to be include in your project as well.
Exception.cls
Option Explicit
'@Exposed
'@Folder("Lapis")
'@PredeclaredId
' The exception that is thrown when a null reference (Nothing in Visual Basic)
' is passed to a method that does not accept it as a valid argument.
Public Sub ArgumentNullException(ByVal ParamName As String, ByVal Message As String)
Err.Raise 513, , "Value cannot be null." & vbNewLine & vbNewLine & _
"Additional information: " & Message & vbNewLine & vbNewLine & _
"Parameter: " & ParamName
End Sub
' The exception that is thrown when one of the arguments provided to a method is not valid.
Public Sub ArgumentException(ByVal ParamName As String, ByVal Message As String)
Err.Raise 518, , "An exception of type ArgumentException was thrown." & vbNewLine & vbNewLine & _
"Additional information: " & Message & vbNewLine & vbNewLine & _
"Parameter: " & ParamName
End Sub
' The exception that is thrown when a method call is invalid for the
' object's current state.
Public Sub InvalidOperationException(ByVal ParamName As String, ByVal Message As String)
Err.Raise 515, , "An exception of type InvalidOperationException was thrown." & vbNewLine & vbNewLine & _
"Additional information: " & Message & vbNewLine & vbNewLine & _
"Parameter: " & ParamName
End Sub
' Occurs when an exception is not caught.
Public Sub UnhandledException(ByVal Message As String)
Err.Raise 517, , "An exception of type UnhandledException was thrown." & vbNewLine & vbNewLine & _
"Additional information: " & Message & vbNewLine & vbNewLine
End Sub
' The exception that is thrown when a file or directory cannot be found.
Public Sub DirectoryNotFoundException(ByVal ParamName As String, ByVal Message As String)
Err.Raise 520, , "An exception of type DirectoryNotFoundException was thrown." & vbNewLine & vbNewLine & _
"Additional information: " & Message & vbNewLine & vbNewLine & _
"Parameter: " & ParamName
End Sub
Tools.bas
Option Explicit
'@Folder("Lapis")
Private Const ModuleName As String = "Tools"
'@Ignore EncapsulatePublicField
Public Fso As New FileSystemObject
' Returns number of text lines based on the specified Stream.
' Throws an ArgumentNullException when Stream is set to nothing.
' Throws an ArgumentException when Stream is closed.
Public Function LinesCount(ByVal Stream As ADODB.Stream) As Long
Const MethodName = "LinesCount"
If Stream Is Nothing Then
Exception.ArgumentNullException "Stream", ModuleName & "." & MethodName
End If
If Tools.IsStreamClosed(Stream) Then
Exception.ArgumentException "Stream", "Stream is closed. " & ModuleName & "." & MethodName
End If
Dim Ln As Long
Stream.Position = 0
Do While Stream.EOS <> True
Stream.SkipLine
Ln = Ln + 1
Loop
LinesCount = Ln
End Function
' Determines if TextStream is closed.
' There is no property of TextStream object (like object.IsClosed) to know directly if Stream is closed
' or not. To know TextStream's state, method will attempt to read cursor position. If it fails
' (throws an error), that will mean Stream is not readable (closed).
' Throws an ArgumentNullException when Stream is set to nothing.
Public Function IsStreamClosed(ByVal Stream As ADODB.Stream) As Boolean
Const MethodName = "IsStreamClosed"
If Stream Is Nothing Then
Exception.ArgumentNullException "Stream", ModuleName & "." & MethodName
End If
On Error Resume Next
Dim i As Long: i = Stream.Position
If Err.Number = 91 Then
IsStreamClosed = True
On Error GoTo 0
ElseIf Err.Number = 0 Then
IsStreamClosed = False
Else
' Other, unexpected error occured. This error has to be moved upward.
Exception.UnhandledException ModuleName & "." & MethodName
End If
End Function
ArrayH.bas
Option Explicit
'@Folder("Helper")
' Item parameter has to be a simple type.
' Arr has to have only one dimension.
Public Function Exists(ByVal Item As Variant, ByRef Arr As Variant) As Boolean
Exists = (UBound(Filter(Arr, Item)) > -1)
End Function
Conclusion
What do you thing about this code?
I'm looking forward to hear your thoughts about this piece. Within a week, I will also submit an import functionality for a review.
VBProject.VBComponents.Import(FilePath)
. This this lets me avoid problems with attributes. \$\endgroup\$