Option Explicit
 
Private Type udtTest
    szString        As String * 255
    lngLong         As Long
    intInteger      As Integer
End Type
 
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" ( _
  pDst As Any, _
  pSrc As Any, _
  ByVal ByteLen As Long _
)
 
Private c   As Class2
 
' callback von Class2
' In einem Code Modul würde CB so aussehen:
'
' Public Function CDB(ByVal this As Object,
'        ByVal dummy1 As Long,
'        ByVal dummy2 As Long,
'        pOut As Long) As Long
'     ...
' End Function
'
' 2 Dummy Argumente, weil CallWindowProc
' 4 Parameter auf den Stack legt.
'
' CB MUSS DIE ERSTE FUNKTION IN DER KLASSE SEIN!
Private Function CB(ByVal msg As Long, ByVal pUDT As Long) As Long
    Dim udt As udtTest
    Select Case msg
        Case 1
            CopyMemory udt, ByVal pUDT, LenB(udt)
            Debug.Print "UDT von Cls 2: " & udt.szString
        Case 2
            Debug.Print "Class 1: Class 2 zerstört"
    End Select
End Function
 
Private Sub Class_Initialize()
    Debug.Print "Class 1 initialisiert"
 
    Set c = New Class2
 
    ' pointer auf diese Klasse für callback übergeben
    c.TerminateCBObj = ObjPtr(Me)
End Sub
 
Private Sub Class_Terminate()
    Debug.Print "Class 1 zerstört"
End Sub

Option Explicit
 
Private Type udtTest
    szString        As String * 255
    lngLong         As Long
    intInteger      As Integer
End Type
 
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" ( _
  pDst As Any, _
  pSrc As Any, _
  ByVal ByteLen As Long _
)
 
Private Declare Function CallWindowProc Lib "user32.dll" _
Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As Long, _
    ByVal msg As Long, _
    ByVal WParam As Long, _
    ByVal lParam As Long _
) As Long
 
Private lngObject   As Long
 
Public Property Let TerminateCBObj(ByVal lng As Long)
    lngObject = lng
End Property
 
Private Sub Class_Initialize()
    Debug.Print "Class 2 initialisiert"
End Sub
 
Private Sub Class_Terminate()
    Dim udt As udtTest
    With udt
        .intInteger = 2
        .lngLong = 4
        .szString = StrConv("hi", vbFromUnicode)
    End With
 
    SendMsg 1, VarPtr(udt)  ' MSG 1: UDT Übergabe
    SendMsg 2               ' MSG 2: Class 2 Terminate
 
    Debug.Print "Class 2 zerstört"
End Sub
 
Private Sub SendMsg(Optional param1 As Long, Optional param2 As Long)
 
    Dim lngVTable   As Long
    Dim lngOffset   As Long
    Dim lngAddr     As Long
    Dim lngRet      As Long
    Dim hResult     As Long
 
    ' erste Funktion von übergebenem Klassenpointer
    ' über VTable herausfinden
    CopyMemory lngVTable, ByVal lngObject, 4
    lngOffset = lngVTable + &H1C
    CopyMemory lngAddr, ByVal lngOffset, 4
 
    ' Funktion aufrufen
    ' Param 1:    Object Pointer
    ' Param 2, 3: Dummy Argumente
    ' Param 4:    Rückgabewert
    hResult = CallWindowProc(lngAddr, _
                             lngObject, _
                             param1, param2, _
                             VarPtr(lngRet))
 
End Sub

http://rm_code.dl.am