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

• Mathieu Guindon: That's pretty nifty, it basically eliminates the need for a separate get-only interface (and lets you have the class' default interface the way you want/need it, which is awesome)... on the other hand I feel like that little chunk of logic needs to be encapsulated into its own class, so it can be easily reused in any class that needs it (should be possible, by passing the necessary pointers). Good job!
• Cristian Buse: @MathieuGuindon Thanks Matt! I need to figure out a simpler process for x32 and then I will post a solution in a separate module. I suspect it has to do with the calling convention difference between x32 and x64.
• TinMan: Very very interesting. I would really like to see this as a Compare method where you can compare private variables of two instances of a class.
• Mathieu Guindon: Ha, moving the functionality elsewhere is tricky, because now you need a data structure (dictionary?) to pass the initializer values around... and it doesn't get any simpler from there (passing the values is easy... retrieving them by name... gets very clunky and stringly-typed, very fast. Ugh!
• Cristian Buse: @TinMan This is a nice idea. This way there is no need to replicate the factory method signature inside the Init method.

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

Immediate Window Results

• Cristian Buse: I've used the UnsignedAddition function (see here) before, when doing pointer arithmetic. Would that be an overkill here? Is it really possible that the pointers will be at the very boundary of sign change? I ask because we merely add 4 or 8 bytes on each iteration.
• TinMan: @CristianBuse I don't understand the need for the offset. I'm guessing that there is some sort of header that doesn't get copied over?
• TinMan: @CristianBuse You use of compiler directives is outstanding. Your pattern with an explanation of when to convert WinAPI Declarations Long to LongPtr belongs on ByteComb.
• Cristian Buse: On x64 the calling convention forces the first 4 parameters into registers and only from the 5th forward will go on stack, meaning that immediately after the VarPtr(Method) (the address of the return value) there is the this pointer passed to the class method in order to identify the instance. On x32 they are pushed on the stack thus making it more difficult to find. Note that Me acts like a variable but when testing it looks like a Property Get because if you save the VarPtr(Me) and then peek at that address there is nothing, just 0. In short, Me is not the hidden This
• Cristian Buse: Thanks. I've never used ByteComb. Is that your website? Feel free to add any of my code / explanations in there if you consider it's useful.