EDIT:
The following changes should make this safe on either 32 or 64 bit hosts (untested due to lack of access to a 64 bit Office install). Declare the following constants:
#If Win64 Then
Private Const POINTER_SIZE As LongPtr = 8
#Else
Private Const POINTER_SIZE As LongPtr = 4
#End If
Private Const INTERFACE_OFFSET As LongPtr = 7 * POINTER_SIZE
Private Const MAKE_FUNCTION_OFFSET As LongPtr = INTERFACE_OFFSET + (2 * POINTER_SIZE)
Private Const INIT_FUNCTION_OFFSET As LongPtr = INTERFACE_OFFSET + (3 * POINTER_SIZE)
Change the Declare Function
to this:
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Any)
And replace Sub SwapFunctions
with this implementation:
Private Sub SwapFunctions()
Dim first As Long
Dim second As Long
'The ObjPtr doesn't matter here - it's the interface, not the instance that matters.
CopyMemory first, ByVal ObjPtr(Me), POINTER_SIZE
CopyMemory second, ByVal first + MAKE_FUNCTION_OFFSET, POINTER_SIZE
CopyMemory ByVal first + INTERFACE_OFFSET, ByVal first + INIT_FUNCTION_OFFSET, POINTER_SIZE
CopyMemory ByVal first + INIT_FUNCTION_OFFSET, second, POINTER_SIZE
End Sub
EDIT:
The following changes should make this safe on either 32 or 64 bit hosts (untested due to lack of access to a 64 bit Office install). Declare the following constants:
#If Win64 Then
Private Const POINTER_SIZE As LongPtr = 8
#Else
Private Const POINTER_SIZE As LongPtr = 4
#End If
Private Const INTERFACE_OFFSET As LongPtr = 7 * POINTER_SIZE
Private Const MAKE_FUNCTION_OFFSET As LongPtr = INTERFACE_OFFSET + (2 * POINTER_SIZE)
Private Const INIT_FUNCTION_OFFSET As LongPtr = INTERFACE_OFFSET + (3 * POINTER_SIZE)
Change the Declare Function
to this:
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Any)
And replace Sub SwapFunctions
with this implementation:
Private Sub SwapFunctions()
Dim first As Long
Dim second As Long
'The ObjPtr doesn't matter here - it's the interface, not the instance that matters.
CopyMemory first, ByVal ObjPtr(Me), POINTER_SIZE
CopyMemory second, ByVal first + MAKE_FUNCTION_OFFSET, POINTER_SIZE
CopyMemory ByVal first + INTERFACE_OFFSET, ByVal first + INIT_FUNCTION_OFFSET, POINTER_SIZE
CopyMemory ByVal first + INIT_FUNCTION_OFFSET, second, POINTER_SIZE
End Sub
- 4.2k
- 1
- 18
- 26
'Point.cls - Predeclared
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Type TPoint
X As Double
Y As Double
End Type
Private this As TPoint
Public Function Make(ByVal X As Double, ByVal Y As Double) As Point
Dim newPoint As Point
Set newPoint = New Point
'This swaps the vtable pointer of this function to the private internal one.
SwapFunctions
'Make the call. Due to the vtable hack, this will call InternalInitialize.
newPoint.Make X, Y
'Reset the vtable to it's initial state.
SwapFunctions
Set Make = newPoint
End Function
Public Property Get X() As Double
X = this.X
End Property
Public Property Get Y() As Double
Y = this.Y
End Property
'This has to be the exact same signature as Make or it will mis-align the stack
Private Function InternalInitialize(ByVal X As Double, ByVal Y As Double) As Point
this.X = X
this.Y = Y
End Function
Private Sub SwapFunctions()
Dim first As Long
Dim second As Long
'The ObjPtr doesn't matter here - it's the interface, not the instance that matters.
CopyMemory first, ByVal ObjPtr(Me), 4
CopyMemory second, ByVal first + &H1C + 8, 4
CopyMemory ByVal first + &H1C, ByVal first + &H1C + 12, 4
CopyMemory ByVal first + &H1C + 12, second, 4
End Sub
'Point.cls - Predeclared
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Type TPoint
X As Double
Y As Double
End Type
Private this As TPoint
Public Function Make(ByVal X As Double, ByVal Y As Double) As Point
Dim newPoint As Point
Set newPoint = New Point
'This swaps the vtable pointer of this function to the private internal one.
SwapFunctions
'Make the call.
newPoint.Make X, Y
'Reset the vtable to it's initial state.
SwapFunctions
Set Make = newPoint
End Function
Public Property Get X() As Double
X = this.X
End Property
Public Property Get Y() As Double
Y = this.Y
End Property
'This has to be the exact same signature as Make or it will mis-align the stack
Private Function InternalInitialize(ByVal X As Double, ByVal Y As Double) As Point
this.X = X
this.Y = Y
End Function
Private Sub SwapFunctions()
Dim first As Long
Dim second As Long
'The ObjPtr doesn't matter here - it's the interface, not the instance that matters.
CopyMemory first, ByVal ObjPtr(Me), 4
CopyMemory second, ByVal first + &H1C + 8, 4
CopyMemory ByVal first + &H1C, ByVal first + &H1C + 12, 4
CopyMemory ByVal first + &H1C + 12, second, 4
End Sub
'Point.cls - Predeclared
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Type TPoint
X As Double
Y As Double
End Type
Private this As TPoint
Public Function Make(ByVal X As Double, ByVal Y As Double) As Point
Dim newPoint As Point
Set newPoint = New Point
'This swaps the vtable pointer of this function to the private internal one.
SwapFunctions
'Make the call. Due to the vtable hack, this will call InternalInitialize.
newPoint.Make X, Y
'Reset the vtable to it's initial state.
SwapFunctions
Set Make = newPoint
End Function
Public Property Get X() As Double
X = this.X
End Property
Public Property Get Y() As Double
Y = this.Y
End Property
'This has to be the exact same signature as Make or it will mis-align the stack
Private Function InternalInitialize(ByVal X As Double, ByVal Y As Double) As Point
this.X = X
this.Y = Y
End Function
Private Sub SwapFunctions()
Dim first As Long
Dim second As Long
'The ObjPtr doesn't matter here - it's the interface, not the instance that matters.
CopyMemory first, ByVal ObjPtr(Me), 4
CopyMemory second, ByVal first + &H1C + 8, 4
CopyMemory ByVal first + &H1C, ByVal first + &H1C + 12, 4
CopyMemory ByVal first + &H1C + 12, second, 4
End Sub
Which leads us to... vtable hacking. The grossly simplified explanation is that an interface is simply a collection of function pointers to the entry points of the class's functionality. The instance of the class is passed as a parameter (along with any others) to that function. So you just swap the vtable entries of your private intializerinitializer (which sets the instance variables) with your factory method, set them, and swap them back:
Which leads us to... vtable hacking. The grossly simplified explanation is that an interface is simply a collection of function pointers to the entry points of the class's functionality. The instance of the class is passed as a parameter (along with any others) to that function. So you just swap the vtable entries of your private intializer (which sets the instance variables) with your factory method, set them, and swap them back:
Which leads us to... vtable hacking. The grossly simplified explanation is that an interface is simply a collection of function pointers to the entry points of the class's functionality. The instance of the class is passed as a parameter (along with any others) to that function. So you just swap the vtable entries of your private initializer (which sets the instance variables) with your factory method, set them, and swap them back: