8
\$\begingroup\$

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

\$\endgroup\$
6
  • \$\begingroup\$ 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! \$\endgroup\$ Oct 13, 2020 at 12:43
  • \$\begingroup\$ @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. \$\endgroup\$ Oct 13, 2020 at 14:29
  • \$\begingroup\$ 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. \$\endgroup\$
    – TinMan
    Oct 13, 2020 at 15:31
  • \$\begingroup\$ 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! \$\endgroup\$ Oct 13, 2020 at 17:19
  • \$\begingroup\$ @TinMan This is a nice idea. This way there is no need to replicate the factory method signature inside the Init method. \$\endgroup\$ Oct 14, 2020 at 10:34

1 Answer 1

4
\$\begingroup\$

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

\$\endgroup\$
10
  • \$\begingroup\$ 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. \$\endgroup\$ Oct 14, 2020 at 11:03
  • \$\begingroup\$ @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? \$\endgroup\$
    – TinMan
    Oct 14, 2020 at 11:10
  • 1
    \$\begingroup\$ @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. \$\endgroup\$
    – TinMan
    Oct 14, 2020 at 11:13
  • 1
    \$\begingroup\$ 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 \$\endgroup\$ Oct 14, 2020 at 11:17
  • \$\begingroup\$ 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. \$\endgroup\$ Oct 14, 2020 at 11:28

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.