x64 カスタムクラスの For Each 列挙のバグ 質問する

実行すると、Mainイミディエイト ウィンドウに次のような結果が表示されます。

戻り値のアドレスは、明らかにメソッドの変数と変数NewEnumの間のメモリ アドレスにあります。そのため、変数はどこからともなく値を取得します。これは、変数が実際にはメソッドのスタック フレーム(オブジェクトの vtable のアドレスやインターフェイスのアドレスなど) から取得されるためです。変数がそこにない場合、メモリのより重要な部分が上書きされるため (例: メソッドのフレーム ポインター アドレス)、クラッシュは明らかです。メソッドのスタック フレームが大きいほど (たとえば、サイズを増やすためにローカル変数を追加できます)、コール スタックの最上位のスタック フレームと下位のスタック フレームの間で共有されるメモリが多くなります。ptr0ptr9ShowBugNewEnumIEnumVariantShowBugNewEnum

質問に記載されているオプションを使用してバグを回避するとどうなりますか?行Set v = Nothingの前にを追加するだけでFor Each v In c、結果は次のようになります。

以前の値と現在の値 (青枠) の両方を表示すると、戻り値がメソッドのおよび変数のNewEnum外側のメモリ アドレスにあることがわかります。回避策を使用してスタック フレームが正しく割り当てられたようです。ptr0ptr9ShowBug

内部でブレークすると、NewEnum呼び出しスタックは次のようになります。

For Each呼び出す方法NewEnum

すべてのVBAクラスは以下から派生していますIDディスパッチ(これは IUnknown から派生します)。

For Each...オブジェクトでループが呼び出されると、そのオブジェクトのIDispatch::Invokeメソッドが -4 に等しい値で呼び出されますdispIDMember。VBA.Collection にはすでにそのようなメンバーがありますが、VBA カスタム クラスの場合は、Attribute NewEnum.VB_UserMemId = -4Invoke がメソッドを呼び出せるように独自のメソッドを でマークします。

InvokeFor Each行で使用されているインターフェースが から派生していない場合、 は直接呼び出されませんIDispatch。代わりに、IUnknown::QueryInterfaceが最初に呼び出され、 IDispatch インターフェースが要求されます。 この場合、 は、InvokeIDispatch インターフェースが返された後にのみ呼び出されるのは明らかです。 これが、For Each宣言されたオブジェクトで を使用してもAs IUnknown、渡されるか、グローバルまたはクラス メンバーのカスタム コレクションであるかに関係なく、バグが発生しない理由ですByRef。 質問に記載されている回避策 1 を使用するだけです (つまり、別のメソッドを呼び出します)。これは見えませんが。

フック呼び出し

さらに調査するために、 VB 以外のInvokeメソッドを独自のメソッドに置き換えることができます。標準.basモジュールでは、フックするために次のコードが必要です。

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
        Public 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 newInvokePtr As LongPtr
    Private oldInvokePtr As LongPtr
    Private invokeVtblPtr As LongPtr
#Else
    Private newInvokePtr As Long
    Private oldInvokePtr As Long
    Private invokeVtblPtr As Long
#End If

'https://learn.microsoft.com/en-us/windows/win32/api/oaidl/nf-oaidl-idispatch-invoke
Function IDispatch_Invoke(ByVal this As Object _
    , ByVal dispIDMember As Long _
    , ByVal riid As LongPtr _
    , ByVal lcid As Long _
    , ByVal wFlags As Integer _
    , ByVal pDispParams As LongPtr _
    , ByVal pVarResult As LongPtr _
    , ByVal pExcepInfo As LongPtr _
    , ByRef puArgErr As Long _
) As Long
    Const DISP_E_MEMBERNOTFOUND = &H80020003
    '
    Debug.Print "The IDispatch::Invoke return address " & VarPtr(IDispatch_Invoke) & " should be outside of the"
    IDispatch_Invoke = DISP_E_MEMBERNOTFOUND
End Function

Sub HookInvoke(obj As Object)
    If obj Is Nothing Then Exit Sub
    #If VBA7 Then
        Dim vTablePtr As LongPtr
    #Else
        Dim vTablePtr As Long
    #End If
    '
    newInvokePtr = VBA.Int(AddressOf IDispatch_Invoke)
    CopyMemory vTablePtr, ByVal ObjPtr(obj), PTR_SIZE
    '
    invokeVtblPtr = vTablePtr + 6 * PTR_SIZE
    CopyMemory oldInvokePtr, ByVal invokeVtblPtr, PTR_SIZE
    CopyMemory ByVal invokeVtblPtr, newInvokePtr, PTR_SIZE
End Sub

Sub RestoreInvoke()
    If invokeVtblPtr = 0 Then Exit Sub
    '
    CopyMemory ByVal invokeVtblPtr, oldInvokePtr, PTR_SIZE
    invokeVtblPtr = 0
    oldInvokePtr = 0
    newInvokePtr = 0
End Sub

Option Explicit

Sub Main2()
    #If Win64 Then
        Dim c As Object
        Set c = New CustomCollection
        c.Add 1
        c.Add 2
        '
        HookInvoke c
        ShowBug2 c
        RestoreInvoke
    #Else
        MsgBox "This bug does not occur on 32 bits!", vbInformation, "Cancelled"
    #End If
End Sub

Sub ShowBug2(ByRef c As CustomCollection)
    Dim ptr00 As LongPtr
    Dim ptr01 As LongPtr
    Dim ptr02 As LongPtr
    Dim ptr03 As LongPtr
    Dim ptr04 As LongPtr
    Dim ptr05 As LongPtr
    Dim ptr06 As LongPtr
    Dim ptr07 As LongPtr
    Dim ptr08 As LongPtr
    Dim ptr09 As LongPtr
    Dim ptr10 As LongPtr
    Dim ptr11 As LongPtr
    Dim ptr12 As LongPtr
    Dim ptr13 As LongPtr
    Dim ptr14 As LongPtr
    Dim ptr15 As LongPtr
    Dim ptr16 As LongPtr
    Dim ptr17 As LongPtr
    Dim ptr18 As LongPtr
    Dim ptr19 As LongPtr
    '
    Dim v As Variant
    '
    On Error Resume Next
    For Each v In c
    Next v
    Debug.Print VarPtr(ptr19) & " - " & VarPtr(ptr00) & " range on the call stack"
    Debug.Assert ptr00 = 0
End Sub

Option Explicit

Sub Main3()
    #If Win64 Then
        Dim c As New Class1
        ShowBug3 c
    #Else
        MsgBox "This bug does not occur on 32 bits!", vbInformation, "Cancelled"
    #End If
End Sub

Sub ShowBug3(ByRef c As Class1)
    Dim ptr0 As LongPtr
    Dim ptr1 As LongPtr
    Dim ptr2 As LongPtr
    Dim ptr3 As LongPtr
    Dim ptr4 As LongPtr
    Dim ptr5 As LongPtr
    Dim ptr6 As LongPtr
    Dim ptr7 As LongPtr
    Dim ptr8 As LongPtr
    Dim ptr9 As LongPtr
    '
    Dim v As Variant
    '
    On Error Resume Next
    For Each v In c
    Next v
    Debug.Assert ptr0 = 0
End Sub

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "EnumHelper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_enum As IEnumVARIANT

Public Property Set EnumVariant(newEnum_ As IEnumVARIANT)
    Set m_enum = newEnum_
End Property
Public Property Get EnumVariant() As IEnumVARIANT
Attribute EnumVariant.VB_UserMemId = -4
    Set EnumVariant = m_enum
End Property

Public Property Get Self() As EnumHelper
    Set Self = Me
End Property

Option Explicit

Private m_coll As Collection

Private Sub Class_Initialize()
    Set m_coll = New Collection
End Sub
Private Sub Class_Terminate()
    Set m_coll = Nothing
End Sub

Public Sub Add(v As Variant)
    m_coll.Add v
End Sub

Public Function NewEnum() As EnumHelper
    With New EnumHelper
        Set .EnumVariant = m_coll.[_NewEnum]
        Set NewEnum = .Self
    End With
End Function