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.
- 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!
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
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
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.
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
Modules, with code, which are used by
SourceControlH module. These has to be include in your project as well.
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
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
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
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.