Private VBA Class Initializer dipanggil dari Pabrik

Question

Saya telah bermain dengan COM akhir-akhir ini dan ketika memahami mekanisme bagaimana metode / properti kelas disebut sebuah ide muncul di benak: bagaimana jika kita dapat memiliki contoh global dari kelas yang mengekspos Pabrik untuk membuat contoh baru dari itu kelas tetapi metode Penginisialisasi adalah Pribadi. Apakah itu mungkin? Jawabannya iya. Kita dapat menggunakan Mevariabel khusus untuk mencari dan mengganti penunjuk instance sehingga kita dapat mengalihkan panggilan ke instance yang diinginkan.

Pertimbangkan Class1mana yang VB_PredeclaredIddisetel ke 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

Sekarang kita dapat membuat dan menggunakan contoh baru seperti ini:

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

bahkan jika Initmetodenya Private.

Saya tidak begitu mengerti mengapa offsetnya adalah 56 byte pada x64 dan 168 byte pada x32 (setidaknya di komputer saya). Alangkah baiknya jika seseorang bisa mengetahui hal ini sehingga loop yang digunakan untuk mencari alamat swap tidak diperlukan lagi.

---

EDIT 1

Ternyata di x64 cukup mendapatkan alamat swap seperti ini:

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

jadi tidak diperlukan putaran.

Edit 2

Saya telah memutuskan untuk membuat pertanyaan tindak lanjut baru dengan kode baru yang ditingkatkan, daripada menjawab pertanyaan ini karena kode di sini lebih lambat dan kurang aman. Pergi ke: Private VBA Class Initializer dipanggil dari Pabrik # 2

Answer 1

Ini bukan banyak review tapi variasi dari teknik OP. Seperti yang disebutkan Mathieu Guindon dalam komentar, "logika perlu dienkapsulasi". Kelas Caster saya melakukan itu. Kelas Person hanya untuk pengujian.

Kastor: Kelas

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

Orang: Kelas

Catatan: Metode Init hanya untuk mendemonstrasikan konsep asli OP. Itu bisa diganti dengan 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

Uji

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