I recently developed a tool which automaticaly generates VBA code in order to smoothly create class templates. I wanted to share this tool with the community, hopefully this is the right place.
The idea is to put the definition of your class on "paper", via an excel spreadsheet:
- Create a new sheet or chose an empty spot on a random sheet
- Type the name of your class in one cell
- All the cells below will contain the name of a member of your class
- The cells adjacent (to the right) of the step 3 cells will provide the type (if the member is a method, leave blank)
- The cells adjacent to the step 4 cells will provide read and write attributes (if the member is a function or a method, leave blank)
- The cells adjacent to the step 5 cells will provide a description of the member (optional)
- The cells adjacent to the step 6 cells go by pairs and will provide the parameters of the member (for functions and methods only, and if relevant). There can be as many pairs as required: column N is the variable name, column N+1 is the variable type
- Select the range containing your data (except the Class name, which will be located just above your selection)
- Run subroutine Main (code provided below)
- The generated code is exported in the Inmediate Window
See below the example of an Excel sheet showing the class definition. The range selection required before running the code is shown in red.
The class template code generated from the above example looks as follows:
'CLIENTFILE
'
'Properties:
' - Id R Long A cumulative Id number (attributed during initialization)
' - FirstName RW String First name
' - LastName RW String Last Name
' - DateOfBirth RW Date Date of Birth
' - Sales RW String Coll A collection of strings which represent sales ID numbers
' - Proposals RW clsProposal coll A collection of clsProposal objects which represent the proposals sent in the past
'Functions:
' - NewProposal clsProposal Returns a Proposal for given sales parameters
'Methods:
' - SendBestWishes Sends a wishes card (why not?)
' - MakePremium Upgrades the client to Premium
Option Explicit
Private lId as Long
Private sFirstName as String
Private sLastName as String
Private dDateOfBirth as Date
Private cSales as New Collection
Private oProposals as New coll
'##### INITIALIZE #####
Private Sub class_Initialize()
Debug.Print "clsClientFile initilized"
End Sub
'##### PROPERTIES #####
'# ID
'A cumulative Id number (attributed during initialization)
Public Property Get Id() as Long
Id = lId
End Property
'# FIRSTNAME
'First name
Public Property Get FirstName() as String
FirstName = sFirstName
End Property
Public Property Let FirstName(Var as String)
sFirstName = Var
End Property
'# LASTNAME
'Last Name
Public Property Get LastName() as String
LastName = sLastName
End Property
Public Property Let LastName(Var as String)
sLastName = Var
End Property
'# DATEOFBIRTH
'Date of Birth
Public Property Get DateOfBirth() as Date
DateOfBirth = dDateOfBirth
End Property
Public Property Let DateOfBirth(Var as Date)
dDateOfBirth = Var
End Property
'# SALES
'A collection of strings which represent sales ID numbers
Public Property Get Sales() as Collection
Set Sales = cSales
End Property
Public Property Set Sales(Var as Collection)
Set cSales = Var
End Property
'# PROPOSALS
'A collection of clsProposal objects which represent the proposals sent in the past
Public Property Get Proposals() as coll
Set Proposals = oProposals
End Property
Public Property Set Proposals(Var as coll)
Set oProposals = Var
End Property
'##### FUNCTIONS #####
'# NEWPROPOSAL
'Returns a Proposal for given sales parameters
Public Function NewProposal(ByVal sTitle as String, ByVal sExpDate as Date) as clsProposal
End Function
'##### METHODS #####
'# SENDBESTWISHES
'Sends a wishes card (why not?)
Public Sub SendBestWishes(ByVal sAddress as String)
End Sub
'# MAKEPREMIUM
'Upgrades the client to Premium
Public Sub MakePremium
End Sub
The source code is provided below:
STANDARD MODULE
Option Explicit
'##### GEN CLASS CODE #####
'Generates code in the Immediate Window
'Select in a Spreadsheet the list of Properties, Functions, and Methods to be incorporated within the Class.
'The row just above the selection provides the Class Name in the cell of column 1 of the selection, and an optionnal Description in column 2.
'Each Row of the selection must represent a Member, and the Columns must be structured as follows: (x = must be provided, o = must not be provided, ? = can be provided)
'Column Property Function Method Comment
' - 1: Member Name x x x
' - 2: Member Variable Type x x o Variable Type of the Variable returned by Property or Function.
' - 3: Member Rights x o o Defines if the Member is Read Only, Write Only, or Both: type 'R', 'W', or 'RW'.
' - 4: Member Description ? ? ? Will be inserted in the Class Summary Header, as well as in the Member Mini Header. Usually empty if the Member is a Property.
' - 5-6+: Member Input Variables o ? ? Pairs of value : column N is VarName, column N+1 is VarType. If more than one Input Variable is required, reapeat with columns 7-8, etc.
'Non-Object Variable Types (Object variables require a Let and New statement)
Private Const cstNonObjectVariables = "Variant, Integer, Long, Single, Double, Currency, Date, String, Boolean, Byte, LongLong, LongPtr"
'Variable Type and their corresponding Prefix (for Hungarian style nomenclature; update cstVariablesPrefix to = "p, p, p, p, p, p, p, p, p, p, p, p, p, " to ignore)
Private Const cstVariableTypes = "Variant, Integer, Long, Single, Double, Currency, Date, String, Boolean, Byte, LongLong, LongPtr, Collection, Object"
Private Const cstVariablesPrefix = "v, i, l, sgl, dbl, ccy, d, s, b, by, h, h, c, o"
'Maximum lengths per column (for Class Summary Header)
Private Const cstMaxLenName = 25
Private Const cstMaxLenRW = 4
Private Const cstMaxLenVarType = 25
Sub main()
'***** PREPARE DATA *****
'# Read and Verify Selection
Dim rngRawInput As Range
Set rngRawInput = Selection
If Selection.Columns.Count > 4 And (Selection.Columns.Count - 4) Mod 2 <> 0 _
Then MsgBox "Selection is wrong, please try again", vbCritical + vbOKOnly, "Excel clsGen": End
If rngRawInput.Columns.Count < 6 Then Set rngRawInput = rngRawInput.Resize(, 6)
'# Save Selection Content
Dim sClassName As String
Dim sClassDescription As String
sClassName = rngRawInput.Offset(-1, 0).Cells(1, 1).Value2
sClassDescription = rngRawInput.Offset(-1, 0).Cells(1, 2).Value2
Dim arrName() As Variant
Dim arrVarType() As Variant
Dim arrRights() As Variant
Dim arrDescription() As Variant
Dim arrInputVars() As Variant
arrName = rngRawInput.Columns(1).Value2
arrVarType = rngRawInput.Columns(2).Value2
arrRights = rngRawInput.Columns(3).Value2
arrDescription = rngRawInput.Columns(4).Value2
arrInputVars = ActiveSheet.Range(Cells(rngRawInput.Row, rngRawInput.Column + 4), _
Cells(rngRawInput.Row + rngRawInput.Rows.Count - 1, rngRawInput.Column + rngRawInput.Columns.Count - 1)).Value2
'# Identify Selection Content Member Types and Populate relevant Collections
Dim cProperties As New Collection
Dim cFunctions As New Collection
Dim cMethods As New Collection
Dim myMember As clsGenClsMember
Dim i As Integer
Dim j As Integer
For i = LBound(arrName) To UBound(arrName)
Set myMember = New clsGenClsMember
With myMember
.Name = arrName(i, 1)
.VarType = Replace(Split(arrVarType(i, 1) & " ", " ")(VBAexcelBasics.FunctionsStrings.strCount(CStr(arrVarType(i, 1)), " ")), "Coll", "Collection", , , vbTextCompare) '"oVariable Coll" -> "Collection" (of oVariable type)
.VarTypeFull = arrVarType(i, 1)
.Rights = arrRights(i, 1)
.Description = arrDescription(i, 1)
.InputVars = Application.WorksheetFunction.Index(arrInputVars, i, 0)
'Input check
If StrComp(.Name, "Val", vbTextCompare) = 0 Then _
MsgBox "Member name cannot be 'val', please try again with another name.", vbCritical + vbOKOnly, "Excel clsGen": End
If Len(.Name) > cstMaxLenName Or Len(.Rights) > cstMaxLenRW Or Len(.VarTypeFull) > cstMaxLenVarType Then _
MsgBox "Member Name, RW statement, and/or Description are too long, please try again with something shorter.", vbCritical + vbOKOnly, "Excel clsGen": End
'Member is a Property
If .Name <> "" And .VarType <> "" And .Rights <> "" And .InputVars(1) = "" Then
cProperties.Add myMember
'Member is a Function
ElseIf .Name <> "" And .VarType <> "" And .Rights = "" And .InputVars(1) <> "" Then
cFunctions.Add myMember
'Member is a Method
ElseIf .Name <> "" And .VarType = "" And .Rights = "" Then
cMethods.Add myMember
'Unable to identify Member kind
Else
MsgBox "Unable to Identify Content of row " & i & " (" & .Name & "). Please verify and try again.", _
vbCritical + vbOKOnly, "Excel clsGen": End
End If
End With
Next
'***** PRINT DATA *****
Dim sPrint As String
Dim sOutput As String
Dim arrNonObjectVariables() As String
arrNonObjectVariables = Split(cstNonObjectVariables, ", ")
'# Print Summary Header
sPrint = "'@ClassName" & vbNewLine _
& "'@ClassDescription" & vbNewLine _
sPrint = Replace(sPrint, "@ClassName", StrConv(Mid(sClassName, 4, Len(sClassName) - 3), vbUpperCase))
sPrint = Replace(sPrint, "@ClassDescription" & vbNewLine, IIf(sClassDescription = "", "", sClassDescription & vbNewLine))
sOutput = sOutput & sPrint
'Properties
sOutput = sOutput & vbNewLine _
& "'Properties:" & vbNewLine
For Each myMember In cProperties
With myMember
sOutput = sOutput & "' - " & .Name & Space(cstMaxLenName - Len(.Name)) _
& .Rights & Space(cstMaxLenRW - Len(.Rights)) _
& .VarTypeFull & Space(cstMaxLenVarType - Len(.VarTypeFull)) _
& .Description & vbNewLine
End With
Next
'Functions
sOutput = sOutput & vbNewLine _
& "'Functions:" & vbNewLine
For Each myMember In cFunctions
With myMember
sOutput = sOutput & "' - " & .Name & Space(cstMaxLenName + cstMaxLenRW - Len(.Name)) _
& .VarTypeFull & Space(cstMaxLenVarType - Len(.VarTypeFull)) _
& .Description & vbNewLine
End With
Next
'Methods
sOutput = sOutput & vbNewLine _
& "'Methods:" & vbNewLine
For Each myMember In cMethods
With myMember
sOutput = sOutput & "' - " & .Name & Space(cstMaxLenName - Len(.Name)) _
& .Description & vbNewLine
End With
Next
sOutput = sOutput & vbNewLine _
& "Option Explicit" & vbNewLine _
& vbNewLine _
& vbNewLine
'# Print Private Variables
For Each myMember In cProperties
With myMember
sPrint = "Private @p@VarName as @New @VarType" & vbNewLine
sPrint = Replace(sPrint, "@VarName", .Name)
sPrint = Replace(sPrint, "@New ", IIf(UBound(Filter(arrNonObjectVariables, .VarType, , vbTextCompare)) > -1, "", "New "))
sPrint = Replace(sPrint, "@p", VarPrefix(.VarType))
sPrint = Replace(sPrint, "@VarType", .VarType)
sOutput = sOutput & sPrint
End With
Next
'# Print Initialize
sPrint = vbNewLine _
& vbNewLine _
& vbNewLine _
& "'##### INITIALIZE #####" & vbNewLine _
& vbNewLine _
& "Private Sub class_Initialize()" & vbNewLine _
& " Debug.Print ""@ClassName initilized"" " & vbNewLine _
& "End Sub" & vbNewLine
sPrint = Replace(sPrint, "@ClassName", sClassName)
sOutput = sOutput & sPrint
'# Print Properties
sPrint = vbNewLine _
& vbNewLine _
& vbNewLine _
& "'##### PROPERTIES #####" & vbNewLine
sOutput = sOutput & sPrint
For Each myMember In cProperties
With myMember
'Prepare Print
sPrint = vbNewLine _
& vbNewLine _
& "'# @VARNAME" & vbNewLine _
& vbNewLine
If InStr(.Rights, "R") <> 0 Then sPrint = sPrint & "'@Description" & vbNewLine _
& "Public Property Get @VarName() as @VarType" & vbNewLine _
& " @Set @VarName = @p@VarName" & vbNewLine _
& "End Property" & vbNewLine
If InStr(.Rights, "W") <> 0 Then sPrint = sPrint & "Public Property @LetSet @VarName(Var as @VarType)" & vbNewLine _
& " @Set @p@VarName = Var" & vbNewLine _
& "End Property" & vbNewLine
'Replace PlaceHolders
sPrint = Replace(sPrint, "@VARNAME", UCase(.Name))
sPrint = Replace(sPrint, "@Description", .Description)
sPrint = Replace(sPrint, "@VarName", .Name)
sPrint = Replace(sPrint, "@VarType", .VarType)
sPrint = Replace(sPrint, "@Set ", IIf(UBound(Filter(arrNonObjectVariables, .VarType, , vbTextCompare)) > -1, "", "Set "))
sPrint = Replace(sPrint, "@p", VarPrefix(.VarType))
sPrint = Replace(sPrint, "@LetSet", IIf(UBound(Filter(arrNonObjectVariables, .VarType, , vbTextCompare)) > -1, "Let", "Set"))
sOutput = sOutput & sPrint
End With
Next
'# Print Functions
sPrint = vbNewLine _
& vbNewLine _
& vbNewLine _
& "'##### FUNCTIONS #####" & vbNewLine
sOutput = sOutput & sPrint
Dim sArgumentPairs
For Each myMember In cFunctions
With myMember
'Prepare Print
sPrint = vbNewLine _
& vbNewLine _
& "'# @NAME" & vbNewLine _
& vbNewLine _
& "'@Description" & vbNewLine _
& "Public Function @Name(@ArgumentPairs) as @VarType" & vbNewLine _
& " " & vbNewLine _
& "End Function" & vbNewLine
'Replace PlaceHolders
sPrint = Replace(sPrint, "@NAME", UCase(.Name))
sPrint = Replace(sPrint, "@Description", .Description)
sPrint = Replace(sPrint, "@Name", .Name)
sPrint = Replace(sPrint, "@VarType", .VarType)
'Check if Arguments List provided
If .InputVars(1) = "" Then
sPrint = Replace(sPrint, "(@ArgumentPairs)", "")
Else
sArgumentPairs = ""
For i = LBound(.InputVars) To UBound(.InputVars) Step 2
If .InputVars(i) = "" Then Exit For
sArgumentPairs = sArgumentPairs & "ByVal " & .InputVars(i) & " as " & .InputVars(i + 1) & ", "
Next
sArgumentPairs = Left(sArgumentPairs, Len(sArgumentPairs) - Len(", "))
sPrint = Replace(sPrint, "@ArgumentPairs", sArgumentPairs)
End If
sOutput = sOutput & sPrint
End With
Next
'# Print Methods
sPrint = vbNewLine _
& vbNewLine _
& vbNewLine _
& "'##### METHODS #####" & vbNewLine
sOutput = sOutput & sPrint
For Each myMember In cMethods
With myMember
'Prepare Print
sPrint = vbNewLine _
& vbNewLine _
& "'# @NAME" & vbNewLine _
& vbNewLine _
& "'@Description" & vbNewLine _
& "Public Sub @Name(@ArgumentPairs)" & vbNewLine _
& " " & vbNewLine _
& "End Sub" & vbNewLine
'Replace PlaceHolders
sPrint = Replace(sPrint, "@NAME", UCase(.Name))
sPrint = Replace(sPrint, "@Description", .Description)
sPrint = Replace(sPrint, "@Name", .Name)
'Check if Arguments List provided
If .InputVars(1) = "" Then
sPrint = Replace(sPrint, "(@ArgumentPairs)", "")
Else
sArgumentPairs = ""
For i = LBound(.InputVars) To UBound(.InputVars) Step 2
If .InputVars(i) = "" Then Exit For
sArgumentPairs = sArgumentPairs & "ByVal " & .InputVars(i) & " as " & .InputVars(i + 1) & ", "
Next
sArgumentPairs = Left(sArgumentPairs, Len(sArgumentPairs) - Len(", "))
sPrint = Replace(sPrint, "@ArgumentPairs", sArgumentPairs)
End If
sOutput = sOutput & sPrint
End With
Next
'# Export Print Code to Immediate Window
Debug.Print sOutput
End Sub
'# Returns the generic prefix of a given Variable Type, according to the Naming Convention
Private Function VarPrefix(sVarType As String) As String
Dim arrVariableTypes() As String
Dim arrVariablesPrefixes() As String
arrVariableTypes = Split(cstVariableTypes, ", ")
arrVariablesPrefixes = Split(cstVariablesPrefix, ", ")
Dim i As Integer
For i = LBound(arrVariableTypes) To UBound(arrVariableTypes)
If StrComp(sVarType, arrVariableTypes(i), vbTextCompare) = 0 Then VarPrefix = arrVariablesPrefixes(i): Exit Function
Next i
'Else it is an Object
VarPrefix = "o"
End Function
CLASS MODULE, Name = clsGenClsMember
Option Explicit
Private sName As String
Private sVarType As String
Private sVarTypeFull As String
Private sRights As String
Private sDescription As String
Private arrInputVars As Variant
Public Property Get Name() As String
Name = sName
End Property
Public Property Let Name(Var As String)
sName = Var
End Property
Public Property Get VarType() As String
VarType = sVarType
End Property
Public Property Let VarType(Var As String)
sVarType = Var
End Property
Public Property Get VarTypeFull() As String
VarTypeFull = sVarTypeFull
End Property
Public Property Let VarTypeFull(Var As String)
sVarTypeFull = Var
End Property
Public Property Get Rights() As String
Rights = sRights
End Property
Public Property Let Rights(Var As String)
sRights = Var
End Property
Public Property Get Description() As String
Description = sDescription
End Property
Public Property Let Description(Var As String)
sDescription = Var
End Property
Public Property Get InputVars() As Variant
InputVars = arrInputVars
End Property
Public Property Let InputVars(Var As Variant)
arrInputVars = Var
End Property

