Private VBA Class Initializer called from Factory

Question

I've been playing with COM lately and while getting to understand the mechanism of how class methods/properties are called an idea came to mind: what if we can have a global instance of a class that exposes a Factory for creating new instances of that class but the Initializer method is Private. Is that possible? The answer is YES. We can make use of the Me special variable to find and replace the instance pointer so that we can redirect calls to the desired instance.

Consider Class1 which has the VB_PredeclaredId set to True:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'@PredeclaredId
Option Explicit

#If Mac Then
    #If VBA7 Then
        Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr
    #Else
        Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long
    #End If
#Else 'Windows
    'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx
    #If VBA7 Then
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    #Else
        Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    #End If
#End If

#If Win64 Then
    Private Const PTR_SIZE As Long = 8
#Else
    Private Const PTR_SIZE As Long = 4
#End If

Private m_name As String
Private m_id As Long

Public Function Factory(ByVal newName As String, ByVal newID As Long) As Class1
    Dim newClass1 As Class1
    Set newClass1 = New Class1
    '
    #If VBA7 Then
        Dim mePtr As LongPtr
        Dim swapAddr As LongPtr
    #Else
        Dim mePtr As Long
        Dim swapAddr As Long
    #End If
    '
    'Find the address where the swap must happen
    'Note we cannot save ObjPtr(Me) to a variable because
    '   we could get the position of that variable instead
    swapAddr = VarPtr(Me)
    Do
        swapAddr = swapAddr + PTR_SIZE
        CopyMemory mePtr, ByVal swapAddr, PTR_SIZE
    Loop Until mePtr = ObjPtr(Me)
    'Debug.Print swapAddr - VarPtr(Me) '56 on x64 and 168 on x32
    '
    CopyMemory ByVal swapAddr, ObjPtr(newClass1), PTR_SIZE
    Init newName, newID
    CopyMemory ByVal swapAddr, mePtr, PTR_SIZE
    '
    Set Factory = newClass1
 End Function

Private Sub Init(ByVal newName As String, ByVal newID As Long)
    m_name = newName
    m_id = newID
End Sub

Public Property Get Name() As String
    Name = m_name
End Property

Public Property Get ID() As Long
    ID = m_id
End Property

Now we could create and use new instances like this:

Sub TestFactory()
    With Class1.Factory("Test", 4)
        Debug.Print .Name
        Debug.Print .ID
    End With
End Sub

even if the Init method is Private.

I don't really understand why the offset is 56 bytes on x64 and 168 bytes on x32 (at least on my computers). Would be nice if somebody could figure this out so that the loop used in finding the swap address is not needed anymore.

---

EDIT 1

Apparently on x64 it is sufficient to get the swap address like this:

    #If Win64 Then
        swapAddr = VarPtr(Factory) + PTR_SIZE
        mePtr = ObjPtr(Me)
    #End If

so no loop would be needed.

Edit 2

I've decided to create a new follow-up question with a new improved code, instead of answering this question because the code here is slower and less safer. Go to: Private VBA Class Initializer called from Factory #2

Answer 1

This is not so much an review but a variation of the OP's technique. As Mathieu Guindon mentioned in the comments the "logic needs to be encapsulated". My Caster class does just that. The Person class is just for testing.

Caster:Class

Attribute VB_Name = "Caster"
Option Explicit

#If Mac Then
    #If VBA7 Then
        Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr
    #Else
        Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long
    #End If
#Else                                            'Windows
    'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx
    #If VBA7 Then
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    #Else
        Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    #End If
#End If

#If Win64 Then
    Private Const PTR_SIZE As Long = 8
#Else
    Private Const PTR_SIZE As Long = 4
#End If

#If VBA7 Then
    Private SourcePointer As LongPtr
    Private DestinationPointer As LongPtr
#Else
    Private SourcePointer As Long
    Private DestinationPointer As Long
#End If

Public Sub SaveAs(ByRef Source As Object, ByRef Destination As Object)
    DestinationPointer = VarPtr(Source)
    Do
        DestinationPointer = DestinationPointer + PTR_SIZE
        CopyMemory SourcePointer, ByVal DestinationPointer, PTR_SIZE
    Loop Until SourcePointer = ObjPtr(Source)

    CopyMemory ByVal DestinationPointer, ObjPtr(Destination), PTR_SIZE
End Sub

Public Sub Restore()
    CopyMemory ByVal DestinationPointer, SourcePointer, PTR_SIZE
End Sub

Person:Class

Note: The Init method is just to demonstrate the OP's original concept. It could be replaced with m = t.

Attribute VB_Name = "Person"
Attribute VB_PredeclaredId = True

Option Explicit

Private Type Members
    DOB As Date
    Name As String
    Sex As String
End Type

Private this As Members

Public Function Factory(pDOB As Date, pName As String, pSex As String) As Person
    DOB = pDOB
    Name = pName
    Sex = pSex
    Set Factory = Clone
End Function

Public Function Clone() As Person
    Dim Object As Person
    Set Object = New Person

    Dim Caster As New Caster
    
    Dim t As Members
    t = this
    Caster.SaveAs Me, Object
    Init t
    Caster.Restore
    Set Clone = Object
End Function

Private Sub Init(t As Members)
    this = t
End Sub

Public Property Get DOB() As Date

    DOB = this.DOB

End Property

Public Property Let DOB(ByVal Value As Date)

    this.DOB = Value

End Property

Public Property Get Name() As String

    Name = this.Name

End Property

Public Property Let Name(ByVal Value As String)

    this.Name = Value

End Property

Public Property Get Sex() As String

    Sex = this.Sex

End Property

Public Property Let Sex(ByVal Value As String)

    this.Sex = Value

End Property

Test

Sub TestClone()
    Dim Tom As New Person
    With Tom
        .DOB = #7/26/1970#
        .Name = "Tom"
        .Sex = "M"
    End With
    
    Debug.Print "TestClone"
    With Tom.Clone
        Tom.Name = "Thomas"
        Debug.Print "DOB: ", .DOB
        Debug.Print "Name: ", .Name
        Debug.Print "Sex: ", .Sex
    End With
    Debug.Print
End Sub

Sub TestFactory()
    Dim Tom As Person
    Set Tom = Person.Factory(#7/26/1970#, "Tom", "M")
    Person.Name = "Thomas"
    Debug.Print "TestFactory"
    With Tom
        Debug.Print "DOB: ", .DOB
        Debug.Print "Name: ", .Name
        Debug.Print "Sex: ", .Sex
    End With
End Sub