MSForms.SomeControl control array class generator
1. this generator is based on Lavolpe's code in here: VBA-Control-Arrays-Imitation-Classes
2. Generator Usage
(1) create a blank class in vba ide
(2) input "Private WithEvents ooo as MSForms.TextBox"
(3) click events combobox to implement all the events of the control
(4) copy whole code of the class
(5) execute this generator to get 3 class files in "code" folder
3. Code Usage
(1) Import 3 class files in "code" folder to current vba project
(2) write code
'in userform
private withevents c as clsTextBoxList
Private Sub UserForm_Initialize()
Set c = New clsTextBoxList
c.Add Me.TextBox1
c.Add Me.TextBox2
c.Add Me.TextBox3
End Sub
Private Sub UserForm_Terminate()
Set c = Nothing
End Sub
Private Sub c_Change(oTextBox As MSForms.TextBox)
MsgBox oTextBox.Text
End Sub
'or in worksheet
private withevents c as clsTextBoxList
Private Sub Worksheet_Activate()
Set c = New clsTextBoxList
c.Add Me.TextBox1
c.Add Me.TextBox2
c.Add Me.TextBox3
End Sub
Private Sub Worksheet_Deactivate()
Set c = Nothing
End Sub
Private Sub c_Change(oTextBox As MSForms.TextBox)
MsgBox oTextBox.Text
End Sub
Re: MSForms.SomeControl control array class generator
Code:
Sub ControlArrayGenerator()
Dim DataObject As Object
Dim reg As Object
Dim strCode As String 'code read from clibboard
Dim strClassName As String 'destination class name
Dim strClassType As String 'destination class name with namespace
Dim i As Long, j As Long 'loop var
Dim strXXXPublic As String 'clsXXX class public part
Dim strXXXPrivate As String 'clsXXXclass private part
Dim strXXXListEvent As String 'clsXXXList class event part
Dim strXXXListRaiseEvent As String 'clsXXXList class raiseevent part
Dim strTemp As String
Dim strSub As String 'Sub or Function, it seems only Sub need
Dim strMethod As String 'Method
Dim strParams As String 'Parameters with prefix and suffix
Dim strParamsAdd As String 'Parameters with added
Dim strParamsBrief As String 'Parameters withot prefix nor suffix
Dim sPath As String
sPath = ThisWorkbook.Path & "\code"
If Dir(sPath, vbDirectory) = "" Then MkDir sPath
Set reg = CreateObject("Vbscript.RegExp")
Set DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
reg.Global = True
reg.MultiLine = True
DataObject.GetFromClipboard
strCode = DataObject.GetText 'get text from clipboard
reg.Pattern = "^('|Rem )[^\r\n]*?$"
strCode = reg.Replace(strCode, "") 'remove all comments
Dim mc As Object
Dim mc2 As Object
reg.Pattern = "WithEvents\s+[^ ]+?\s+As\s+([^ .]*?\.*)([^ .]+?)$" 'get the destination package class name
Set mc = reg.Execute(strCode)
If mc.Count = 1 Then
strClassName = mc(0).SubMatches(1)
strClassType = mc(0).SubMatches(0) & strClassName
Else
MsgBox "generator donot accept none nor more than one WithEvents"
End If
Dim arrTemp(1 To 3) As String '1:IXXX, 2:clsXXX, 3:clsXXXList
arrTemp(1) = ClassHeader("I" & strClassName) 'IClass
arrTemp(2) = ClassHeader("cls" & strClassName) 'clsClass
arrTemp(3) = ClassHeader("cls" & strClassName & "List") 'clsClassList
'$1 $2 $3
reg.Pattern = "Private\s+(Sub|Function)+?\s+[^ _]+?_([^ _]+?)\(([^\r\n]*?)\)$"
Set mc = reg.Execute(strCode)
If mc.Count Then
For i = 1 To mc.Count
strSub = mc(i - 1).SubMatches(0)
strMethod = mc(i - 1).SubMatches(1)
strParams = mc(i - 1).SubMatches(2)
strParamsAdd = "o" & strClassName & " As " & strClassType & IIf(Len(strParams), ", " & strParams, "")
'handle parameters
reg.Pattern = "(ByRef\s+|ByVal\s+)*([^ ]+?)\s+As\s+([^,]+?)(, |$)"
strParamsBrief = reg.Replace(strParams, "$2$4")
arrTemp(1) = arrTemp(1) & "Public " & strSub & " " & strMethod & "(" & strParamsAdd & ")" & vbCrLf & _
"End " & strSub & vbCrLf & vbCrLf
strXXXPublic = strXXXPublic & "Public " & strSub & " " & strMethod & "(" & strParams & ")" & vbCrLf & _
" myInterface." & strMethod & " myObject" & IIf(Len(strParams), ", " & strParamsBrief, "") & vbCrLf & _
"End " & strSub & vbCrLf
strXXXListEvent = strXXXListEvent & "Public Event " & strMethod & "(" & strParamsAdd & ")" & vbCrLf
strXXXPrivate = strXXXPrivate & "Private " & strSub & " myObject_" & strMethod & "(" & strParams & ")" & vbCrLf & _
" Me." & strMethod & " " & strParamsBrief & vbCrLf & _
"End " & strSub & vbCrLf
strXXXListRaiseEvent = strXXXListRaiseEvent & "Private " & strSub & " I" & strClassName & "_" & strMethod & "(" & strParamsAdd & ")" & vbCrLf & _
" RaiseEvent " & strMethod & "(o" & strClassName & IIf(Len(strParams), ", " & strParamsBrief, "") & ")" & vbCrLf & _
"End " & strSub & vbCrLf
Next i
End If
WriteFile sPath & "\I" & strClassName & ".cls", arrTemp(1)
arrTemp(2) = arrTemp(2) & "Private WithEvents myObject As " & strClassType & vbCrLf & _
"Attribute myObject.VB_VarHelpID = -1" & vbCrLf & _
"Private myInterface As I" & strClassName & vbCrLf & vbCrLf & _
"Public Function zSetReference(o" & strClassName & "s As Variant, CallBackInteface As I" & strClassName & ")" & vbCrLf & _
" If myInterface Is Nothing Then" & vbCrLf & _
" Set myObject = o" & strClassName & "s" & vbCrLf & _
" Set myInterface = CallBackInteface" & vbCrLf & _
" End If" & vbCrLf & _
"End Function" & vbCrLf & vbCrLf & _
"Public Function zRemoveReference()" & vbCrLf & _
" If Not myInterface Is Nothing Then" & vbCrLf & _
" Set myObject = Nothing" & vbCrLf & _
" Set myInterface = Nothing" & vbCrLf & _
" End If" & vbCrLf & _
"End Function" & vbCrLf & vbCrLf & _
"Public Property Get Object() As " & strClassType & vbCrLf & _
" Set Object = myObject" & vbCrLf & _
"End Property" & vbCrLf & vbCrLf & _
"Private Sub Class_Terminate()" & vbCrLf & _
" Set myInterface = Nothing" & vbCrLf & _
" Set myObject = Nothing" & vbCrLf & _
"End Sub" & vbCrLf & vbCrLf
WriteFile sPath & "\cls" & strClassName & ".cls", arrTemp(2) & strXXXPublic & vbCrLf & strXXXPrivate
arrTemp(3) = arrTemp(3) & strXXXListEvent & vbCrLf
arrTemp(3) = arrTemp(3) & "Implements I" & strClassName & vbCrLf & _
"Private myObjects As Collection" & vbCrLf & vbCrLf & _
"Public Function Add(o" & strClassName & " As " & strClassType & ")" & vbCrLf & _
" If Exists(sKey) = False Then" & vbCrLf & _
" myObjects.Add New cls" & strClassName & ", o" & strClassName & ".Name" & vbCrLf & _
" myObjects(myObjects.Count).zSetReference o" & strClassName & ", Me" & vbCrLf & _
" Add = True" & vbCrLf & _
" Else" & vbCrLf & _
" Add = False '""Collection已存在该Key""" & vbCrLf & _
" End If" & vbCrLf & _
"End Function" & vbCrLf & vbCrLf
arrTemp(3) = arrTemp(3) & "Public Function Exists(ByVal sKey As String) As Boolean" & vbCrLf & _
" Dim s: Err.Clear" & vbCrLf & _
" On Error Resume Next" & vbCrLf & _
" s = myObjects(sKey)" & vbCrLf & _
" Exists = (Err.Number = 0)" & vbCrLf & _
" Err.Clear" & vbCrLf & _
"End Function" & vbCrLf & vbCrLf
arrTemp(3) = arrTemp(3) & "Public Sub Remove(ByVal IndexOrName)" & vbCrLf & _
" myObjects(IndexOrName).zRemoveReference" & vbCrLf & _
" myObjects.Remove IndexOrName" & vbCrLf & _
"End Sub" & vbCrLf & vbCrLf
arrTemp(3) = arrTemp(3) & "Public Property Get Count() As Long" & vbCrLf & _
" If Not myObjects Is Nothing Then Count = myObjects.Count" & vbCrLf & _
"End Property" & vbCrLf & vbCrLf & _
"Public Property Get Control(IndexOrName As Variant) As " & strClassType & vbCrLf & _
" On Error Resume Next" & vbCrLf & _
" Set Control = myObjects.Item(IndexOrName).Object" & vbCrLf & _
"End Property" & vbCrLf & vbCrLf & _
"Public Property Get ControlEvent(IndexOrName As Variant) As cls" & strClassName & vbCrLf & _
" On Error Resume Next" & vbCrLf & _
" Set ControlEvent = myObjects.Item(Index)" & vbCrLf & _
"End Property" & vbCrLf & vbCrLf
arrTemp(3) = arrTemp(3) & "Private Sub Class_Initialize()" & vbCrLf & _
" Set myObjects = New Collection" & vbCrLf & _
"End Sub" & vbCrLf & vbCrLf
arrTemp(3) = arrTemp(3) & "Private Sub Class_Terminate()" & vbCrLf & _
" Dim i As Long" & vbCrLf & _
" For i = 1 To myObjects.Count" & vbCrLf & _
" myObjects(1).zRemoveReference" & vbCrLf & _
" myObjects.Remove 1" & vbCrLf & _
" Next i" & vbCrLf & _
" Set myObjects = Nothing" & vbCrLf & _
"End Sub" & vbCrLf & vbCrLf & strXXXListRaiseEvent
WriteFile sPath & "\cls" & strClassName & "List.cls", arrTemp(3)
End Sub
Function ClassHeader(ByVal strClassName As String) As String
ClassHeader = "VERSION 1.0 CLASS" & vbCrLf & _
"BEGIN" & vbCrLf & _
" MultiUse = -1 'True" & vbCrLf & _
"END" & vbCrLf & _
"Attribute VB_Name = """ & strClassName & """" & vbCrLf & _
"Attribute VB_GlobalNameSpace = False" & vbCrLf & _
"Attribute VB_Creatable = False" & vbCrLf & _
"Attribute VB_PredeclaredId = False" & vbCrLf & _
"Attribute VB_Exposed = False" & vbCrLf & vbCrLf
End Function
Public Sub WriteFile(ByVal strFile$, ByVal strValue$)
Dim fNum%
fNum = FreeFile()
Open strFile For Output As #fNum
Print #fNum, strValue,
Close #fNum
End Sub