MSForms.SomeControl control array class generator

[loquat]

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

[loquat]

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