Factory class that uses reflection to instantiate objects by class name

In this SO post Dynamically choose class from string Alexander Platonov creates a Function on the fly and then uses Application.Run() to instantiate an Object by it's class name. Eureka Reflection in VBA!! How evil! How inspiring!! So that began my journey into the darkness.

My quest for power over Reflection spawn the ReflectionFactory class. The default instance of this class modifies itself by adding clauses to a Select Case. This allows me to instantiate the Objects by their class names using the New keyword.

IAnimal:Interface

Option Explicit

Public Function Speak() As String
End Function

Dog:Class

Option Explicit
Implements IAnimal

Public Function Speak() As String
    Const Phrase As String = "Ruff Ruff Ruff"
    Debug.Print TypeName(Me); " says:"; """"; Phrase; """"
    Application.Speech.Speak Phrase
    Speak = Phrase
End Function

Private Function IAnimal_Speak() As String
    Speak
End Function

Cat:Class

Option Explicit
Implements IAnimal

Public Function Speak() As String
    Const Phrase As String = "Meow Meow Meow"
    Debug.Print TypeName(Me); " says:"; """"; Phrase; """"
    Application.Speech.Speak Phrase
    Speak = Phrase
End Function

Private Function IAnimal_Speak() As String
    Speak
End Function

ReflectionFactory:Class

Attribute VB_Name = "ReflectionFactory"
Attribute VB_PredeclaredId = True

Option Explicit
Private Const InsertAfter As String = "'" & "@Case ClassName InsertAfter"
Private Const vbext_ct_ClassModule As Long = 2

Public Sub AddClasses(ParamArray ClassNames() As Variant)
    Dim StartLine As Long
    Dim ClassName

    With getCodeModule
        For Each ClassName In ClassNames
            If Not .Find("Case*New " & ClassName, 1, 1, 1, 1, , , True) Then
                .Find InsertAfter, StartLine, 1, 1, 1
                .InsertLines StartLine + 1, getClassNameCase(CStr(ClassName))
            End If
        Next
    End With
End Sub

Public Sub Build()
    Dim VBComp As Object
    For Each VBComp In ThisWorkbook.VBProject.VBComponents
        If VBComp.Type = vbext_ct_ClassModule Then
            AddClasses VBComp.Name
        End If
    Next
End Sub

Private Function getCodeModule() As Object
    Set getCodeModule = ThisWorkbook.VBProject.VBComponents(TypeName(Me)).CodeModule
End Function

Private Function getClassNameCase(ByVal ClassName As String) As String
    getClassNameCase = vbTab & vbTab & "Case " & Chr(34) & ClassName & Chr(34) & ": Set CreateObject = New " & ClassName
End Function

Public Property Get CreateObject(ByVal ClassName As String) As Object
    Select Case ClassName
    '@Case ClassName InsertAfter
        Case "IAnimal": Set CreateObject = New IAnimal
        Case "MasterFactory": Set CreateObject = New MasterFactory
        Case "Dog": Set CreateObject = New Dog
        Case "Cat": Set CreateObject = New Cat

    End Select
End Property

Test

Sub ThisIsTooFun()
    Dim kitty As IAnimal, puppy As IAnimal, Animal As IAnimal
    ReflectionFactory.Build

    Set kitty = ReflectionFactory.CreateObject("Cat")
    Set puppy = ReflectionFactory.CreateObject("Dog")
    Set Animal = ReflectionFactory.CreateObject(Choose(WorksheetFunction.RandBetween(1, 2), "Cat", "Dog"))

    kitty.Speak
    puppy.Speak
    Animal.Speak
End Sub

Results

In truth, I will probably never use it but boy was it fun to get it working!!!

I'm still interested in your feedback. Do you think that it has any real world applications? Hmmm... Java Bean too outdated. VBA Bean for use in a Visual Bean Application.