VBAの終了タイミングと終了処理の記述 サンプルコード

「VBAの終了タイミングと終了処理の記述」で紹介した内容のサンプルコードをまとめています。

Private Type IID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

' インスタンスのデータ
Private Type MyClassData
    vtblPtr As LongPtr
    RefCount As Long
#If Win64 Then ' 64ビット版かどうか
    Padding As Long
#End If
End Type

' 仮想関数テーブルのデータ
Private Type IUnknownVtbl
    QueryInterface As LongPtr
    AddRef As LongPtr
    Release As LongPtr
End Type

Private Const S_OK As Long = 0
Private Const E_NOINTERFACE As Long = &H80004002
Private Const E_POINTER As Long = &H80004003

Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
    (ByRef Destination As Any, ByRef Source As Any, ByVal Length As LongPtr)
Public Declare PtrSafe Function GetProcessHeap Lib "kernel32.dll" () As LongPtr
Public Declare PtrSafe Function HeapAlloc Lib "kernel32.dll" _
    (ByVal hHeap As LongPtr, ByVal dwFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Public Declare PtrSafe Function HeapFree Lib "kernel32.dll" _
    (ByVal hHeap As LongPtr, ByVal dwFlags As Long, ByVal lpMem As LongPtr) As Boolean

Public Declare PtrSafe Function CoTaskMemAlloc Lib "ole32.dll" _
    (ByVal cb As LongPtr) As LongPtr
Public Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" _
    (ByVal pv As LongPtr)

' VBA実行中は自前インスタンスが入り続ける変数
Dim m_unk As IUnknown

' 変数に関数アドレスを代入するために用いる関数
Private Function GetAddressOf(ByVal func As LongPtr) As LongPtr
    GetAddressOf = func
End Function

' MyClassData と IUnknownVtbl のサイズを合わせたデータを指すポインターを返す
Private Function CreateInstanceMemory() As LongPtr
    Dim p As LongPtr, d As MyClassData, v As IUnknownVtbl
    ' MyClassData と IUnknownVtbl のサイズを合わせたデータを作成
    p = CoTaskMemAlloc(Len(d) + Len(v))
    If p <> 0 Then
        ' 最初の参照カウントは必ず 1 とする
        d.RefCount = 1
        ' MyClassData の直後に IUnknownVtbl を置くので p に MyClassData のサイズを加えたアドレスをセットする
        d.vtblPtr = p + Len(d)
        ' 割り当てたメモリブロックの先頭を MyClassData のデータで埋める
        Call CopyMemory(ByVal p, d, Len(d))
        ' 仮想関数テーブルの作成
        v.QueryInterface = GetAddressOf(AddressOf My_QueryInterface)
        v.AddRef = GetAddressOf(AddressOf My_AddRef)
        v.Release = GetAddressOf(AddressOf My_Release)
        ' 仮想関数テーブルを p + Len(d) の部分にコピー
        Call CopyMemory(ByVal d.vtblPtr, v, Len(v))
    End If
    CreateInstanceMemory = p
End Function

' HRESULT STDMETHODCALLTYPE QueryInterface(THIS_ REFIID refiid, LPVOID FAR* ppv)
' 別のインターフェイスへ変換するのをリクエストするときに呼び出される関数
' (ppv は念のため NULL チェックを入れるため ByVal で定義)
Private Function My_QueryInterface(ByVal This As LongPtr, ByRef refiid As IID, ByVal ppv As LongPtr) As Long
    Debug.Print "My_QueryInterface"
    If ppv = 0 Then
        Debug.Print "  E_POINTER"
        My_QueryInterface = E_POINTER
        Exit Function
    End If
    ' IID_IUnknown: {00000000-0000-0000-C000-000000000046} かどうか確認
    If refiid.Data1 = 0 And refiid.Data2 = 0 And refiid.Data3 = 0 And _
        refiid.Data4(0) = &HC0 And refiid.Data4(1) = 0 And _
        refiid.Data4(2) = 0 And refiid.Data4(3) = 0 And _
        refiid.Data4(4) = 0 And refiid.Data4(5) = 0 And _
        refiid.Data4(6) = 0 And refiid.Data4(7) = &H46 Then
        ' IID_IUnknown の場合は ppv が指すポインターの先に This のアドレス(This の値)をコピー
        Debug.Print "  IID_IUnknown"
        Call CopyMemory(ByVal ppv, This, Len(This))
        ' さらに参照カウントを増やす
        Call My_AddRef(This)
        My_QueryInterface = S_OK
        Exit Function
    End If
    ' IID_IUnknown 以外はサポートしない
    Debug.Print "  E_NOINTERFACE"
    My_QueryInterface = E_NOINTERFACE
End Function

' ULONG STDMETHODCALLTYPE AddRef(THIS)
' 参照カウントを増やす際に呼び出される関数
Private Function My_AddRef(ByVal This As LongPtr) As Long
    Dim d As MyClassData
    ' インスタンスのデータを一旦 d にコピーし、
    ' 参照カウントを増やしたら書き戻す
    Call CopyMemory(d, ByVal This, Len(d))
    d.RefCount = d.RefCount + 1
    Debug.Print "My_AddRef: new RefCount ="; d.RefCount
    Call CopyMemory(ByVal This, d, Len(d))
    ' 戻り値は参照カウント
    My_AddRef = d.RefCount
End Function

' ULONG STDMETHODCALLTYPE Release(THIS)
' 参照カウントを減らす際に呼び出される関数(0 になったら破棄)
Private Function My_Release(ByVal This As LongPtr) As Long
    Dim d As MyClassData
    ' インスタンスのデータを一旦 d にコピーし、
    ' 参照カウントを減らしたら書き戻す
    Call CopyMemory(d, ByVal This, Len(d))
    d.RefCount = d.RefCount - 1
    Debug.Print "My_Release: new RefCount ="; d.RefCount
    Call CopyMemory(ByVal This, d, Len(d))
    ' 参照カウントが 0 になったら CoTaskMemFree で破棄する
    If d.RefCount = 0 Then
        Call CoTaskMemFree(This)
        ' 終了関数を呼び出す
        Call OnExit
    End If
    ' 戻り値は参照カウント
    My_Release = d.RefCount
End Function

' OnExit プロシージャが呼び出されるように
' 自前 IUnknown インスタンスを変数にセットする
Public Sub SetExitHandler()
    Dim p As LongPtr
    ' インスタンスを作成
    p = CreateInstanceMemory()
    If p = 0 Then Exit Sub
    Dim unk As IUnknown
    ' unk を p が指すインスタンスに設定
    Call CopyMemory(unk, p, Len(p))
    ' m_unk にセット(内部で My_AddRef が呼び出される)
    Set m_unk = unk
End Sub

' VBA終了時の処理を記述
Public Sub OnExit()
    Debug.Print "OnExit called"
End Sub