[VBA]VBＡ単独でFor Eachに対応した自作クラスを作成する方法(64bit Excel対応)

2020年11月15日2022年3月20日

1. はじめに
2. 前提条件
3. 説明
4. おわりに
5. プログラムの利用について

はじめに

今回はVBＡ単独でFor Eachに対応した自作クラスを作成する方法を説明します。この手の説明では、よくCollectionかDictionaryの_NewEnum()を呼び出す手法を紹介しているサイトがありますが、本記事では任意のデータ構造をFor Eachに対応させます。具体的には、WindowsAPIを使用してIEnumVARIANTインターフェイスを持つCOMオブジェクトをメモリ上に作成します。なお、今回説明する実装は、ウィルス対策ソフトが反応して実効速度が遅くなる場合があるため、環境次第では注意して下さい(ちなみにAviraは大丈夫でした)。

前提条件

ソースコードはVBA中級者以上兼ポインタを使用する言語の経験者でないと理解できません。そのため、この記事の読者は、ある程度の力量があることを前提とし、VBEの基本的な機能や使い方は説明しません。本記事の本文ではマクロ有効ブックにForEachを実装する手順のみを解説しております。動作原理やアルゴリズム等は全てソースコードのコメントに残しているため、必要な場合はそちらを読んで下さい。
(コメント欄等で質問頂ければ基本的にはお答えします)

説明

IEnumVARIANTインターフェイスを持つCOMオブジェクトの生成用関数の定義

適当なマクロ有効ブックを用意します。

標準モジュールを新規追加し、名前をMEnumeratorBaseに変更して、下記のコードを貼り付けます。

' [VBA]VBＡ単独でFor Eachに対応した自作クラスを作成する方法(64bit Excel対応) 
' Copyright (c) 2020-2024  黒箱 
' This software is released under the GPLv3. 
' このソフトウェアはGNU GPLv3の下でリリースされています。 

'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
' @file           MEnumeratorBase
' @brief          IEnumVARIANTを生成するための共通関数
' @date           2020.11.15
' $Version:       1
' $Revision:      0
' @note           なし
'
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

Option Explicit

Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function CoTaskMemAlloc Lib "ole32" (ByVal cb As LongPtr) As LongPtr
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As Long
Private Declare PtrSafe Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As LongPtr)


'NULLの代用
Private Const NUL As LongPtr = 0


'COMのエラー処理で使用するHRESULT型(一部) https://docs.microsoft.com/en-us/windows/desktop/learnwin32/error-handling-in-com
Public Enum HRESULT
    E_UNEXPECTED = &H8000FFFF   '予期しない状態。
    E_INVALIDARG = &H80070057   'パラメータ値が無効です。
    E_OUTOFMEMORY = &H8007000E  'メモリ不足。
    E_ACCESSDENIED = &H80070005 'アクセスが拒否されました。
    E_FAIL = &H80004005         '不特定のエラー。
    E_POINTER = &H80004003      'ポインタ値に対してNULLが誤って渡されました。
    E_NOINTERFACE = &H80004002  'インターフェイスが存在しません。
    E_NOTIMPL = &H80004001      'インターフェイスが実装されていません。
    S_OK = &H0                  '成功
    S_FALSE = &H1               '成功
End Enum

'IEnumVARIANT::Nextの引数rbVarの型として使用
Public Type EnumVariables
    Element(0) As Variant
End Type


'* @fn Public Function CreateComEnumerator(ByVal EnumMemberPtr As LongPtr, ByVal EnumMemberSize As LongPtr) As IEnumVARIANT
'* @brief IEnumVARIANTインターフェイスを持つCOMオブジェクトのインスタンスを生成します。
'* @param[in] EnumMemberPtr IEnumVARIANTインターフェイスを持つCOMオブジェクトのメンバ変数(構造体)へのポインタを指定します。
'* @param[in] EnumMemberSize EnumMemberPtrの実際のバイト数を指定します。
'* @return 生成したインスタンスを返します。
'* @details この関数の実際の機能は、引数EnumMemberPtrで指定されたメンバを使用してCOMオブジェクトを生成し、これをIEnumVARIANT型にキャストするだけです。生成されたオブジェクトがIEnumVARIANTとして振舞うためには、EnumMemberPtrに適切な仮想関数テーブルを設定しておく必要があります。
'*
Public Function CreateComEnumerator(ByVal EnumMemberPtr As LongPtr, ByVal EnumMemberSize As LongPtr) As IEnumVARIANT
    
    'COMオブジェクト用のヒープメモリ確保
    Dim pThis As LongPtr: pThis = CoTaskMemAlloc(EnumMemberSize)
    If (pThis = NUL) Then Exit Function
    
    'EnumMemberPtrの内容からIEnumVARIANTのインスタンスを作成
    Call CopyMemory(ByVal pThis, ByVal EnumMemberPtr, EnumMemberSize)
    
    '呼び出し元関数のスタック解放時に、EnumMember内の配列またはオブジェクトの参照カウントがデクリメントされないようにする
    Call ZeroMemory(ByVal EnumMemberPtr, EnumMemberSize)
    
    '戻り値に作成したオブジェクトを設定
    UnsafeSet(VarPtr(CreateComEnumerator)) = pThis

End Function

'* @fn Private Function CopyIidToStringType(ByVal riid As LongPtr) As String
'* @brief IIDを文字列型に格納します。
'* @param[in] RIid IIDへの参照を指定します。
'* @return
'* @details IIDは16バイトの構造体であるため、比較演算を容易にするために文字列型に格納します。
'* @note Type IID
'* @note     Data1 As Long
'* @note     Data2 As Integer
'* @note     Data3 As Integer
'* @note     Data4(0 To 7) As Byte
'* @note End Type
'*
Private Function CopyIidToStringType(ByVal RIid As LongPtr) As String
    'IID(GUID)は16バイト、VBAの1文字は2バイトであるためバッファは8文字
    CopyIidToStringType = Space(8)
    Call CopyMemory(ByVal StrPtr(CopyIidToStringType), ByVal RIid, 16)
End Function


'* @fn Private Function GetIidFromText(ByRef IidText As String) As String
'* @brief IIDを示す文字列からIID(文字列型)を生成します。
'* @param[in] IidText IIDを示す文字列を指定します。文字列は{}で囲まれた16進数とハイフンの組合せです。
'* @return IIDを文字列型で返します。
'* @details IIDは本来16バイトの構造体ですが、比較演算を容易にするために文字列型に格納して返します。
'*
Private Function GetIidFromText(ByRef IidText As String) As String
    GetIidFromText = Space(8)
    Call IIDFromString(StrPtr(IidText), StrPtr(GetIidFromText))
End Function


'引数を戻り値に返すだけの関数です。AddressOfで取得した関数ポインタを変数に格納するために使用します。
Public Function GetAddressOf(ByVal FunctionPointer As LongPtr) As LongPtr
    GetAddressOf = FunctionPointer
End Function

'* @fn Public Function RiidIsIEnumerator(ByVal riid As LongPtr) As Boolean
'* @brief 引数で指定したRIIDをチェックし、IUnknownかIEnumVARIANTの場合はTrue、それ以外はFalseを返します。
'* @param[in] riid  チェックするIIDへのポインタを指定します。
'* @return 引数で指定したRIIDがIUnknownかIEnumVARIANTの場合はTrue、それ以外はFalseを返します。
'* @details
'*
Public Function RIidIsIEnumerator(ByVal RIid As LongPtr) As Boolean

    Static IidOfIUnknown As String
    Static IidOfIEnumVARIANT As String
    
    Static Init As Boolean
    If Not (Init) Then
        IidOfIUnknown = GetIidFromText("{00000000-0000-0000-C000-000000000046}")
        IidOfIEnumVARIANT = GetIidFromText("{00020404-0000-0000-C000-000000000046}")
        Init = True
    End If
    
    
    Select Case CopyIidToStringType(RIid)
        Case IidOfIUnknown:     RIidIsIEnumerator = True
        Case IidOfIEnumVARIANT: RIidIsIEnumerator = True
        Case Else:              RIidIsIEnumerator = False
    End Select


End Function


'* @fn Public Property Let UnsafeSet(ByVal ppLHS As LongPtr, ByVal pRHS As LongPtr)
'* @brief LongPtr型変数の値(アドレス)を参照型に代入します。
'* @param[out] RefTypeVarAddress 代入される参照型のアドレスをしてします。この引数には通常VarPtr(obj)を指定します。
'* @param[in]  Address  代入するアドレスを指定します。
'* @details  このプロパティの実際の機能は、ポインタ変数へのアドレス(RefTypeVarAddress)を逆参照して、これに指定したアドレス(Address)を代入します。
'*
Public Property Let UnsafeSet(ByVal RefTypeVarAddress As LongPtr, ByVal Address As LongPtr)
#If Win64 Then
    Const SizeOfPointer = 8
#Else
    Const SizeOfPointer = 4
#End If
    Call CopyMemory(ByVal RefTypeVarAddress, Address, SizeOfPointer)
End Property

標準モジュールを新規追加し、名前をMEnumeratorに変更して、下記のコードを貼り付けます。

' [VBA]VBＡ単独でFor Eachに対応した自作クラスを作成する方法(64bit Excel対応) 
' Copyright (c) 2020-2024  黒箱 
' This software is released under the GPLv3. 
' このソフトウェアはGNU GPLv3の下でリリースされています。 

'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
' @file           MEnumerator
' @brief          IEnumeratorを呼び出すIEnumVARIANTを生成するための関数
' @date           2020.11.15
' $Version:       1
' $Revision:      0
' @note           カスタムクラス設計者はIIteratorインターフェイスを実装したクラスのインスタンをNew_Enumerator()に渡すことで列挙子を生成できます。
'
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

Option Explicit

Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal pv As LongPtr)

#If Win64 Then
'    '下記APIが見付からないためコメントアウト
'    Public Declare PtrSafe Function InterlockedIncrement64 Lib "kernel32" (ByRef lpAddend As LongLong) As LongLong
'    Public Declare PtrSafe Function InterlockedDecrement64 Lib "kernel32" (ByRef lpAddend As LongLong) As LongLong
#Else
    Private Declare PtrSafe Function InterlockedIncrement Lib "kernel32" (ByRef Addend As Long) As Long
    Private Declare PtrSafe Function InterlockedDecrement Lib "kernel32" (ByRef Addend As Long) As Long
#End If

Private Const NUL As LongPtr = 0

'EnumVARIANTのメンバ
Private Type SEnumVARIANT
    VTablePtr  As LongPtr
    References As LongPtr
    Iterator   As IIterator
End Type


'VTable
Private VTable(6) As LongPtr

'* @fn Private Sub InitVTable()
'* @brief IEnumVariant用の仮想関数テーブルを初期化します。
'*
Private Sub InitVTable()
    VTable(0) = GetAddressOf(AddressOf IUnknown_QueryInterface)
    VTable(1) = GetAddressOf(AddressOf IUnknown_AddRef)
    VTable(2) = GetAddressOf(AddressOf IUnknown_Release)
    VTable(3) = GetAddressOf(AddressOf IEnumVARIANT_Next)
    VTable(4) = GetAddressOf(AddressOf IEnumVARIANT_Skip)
    VTable(5) = GetAddressOf(AddressOf IEnumVARIANT_Reset)
    VTable(6) = GetAddressOf(AddressOf IEnumVARIANT_Clone)
End Sub


'* @fn Public Function New_Iterator(ByVal Iterator As IIterator) As IEnumVARIANT
'* @brief ForEach内でIIteratorを実行するCOMオブジェクトを生成します。
'* @param[in] Iterator ForEachで呼び出されるIIteratorのインスタンスを指定します。
'* @return IEnumVARIANTインターフェイスを持つCOMオブジェクトを返します。
'*
Public Function New_Enumerator(ByVal Iterator As IIterator) As IEnumVARIANT
    If (VTable(0) = NUL) Then Call InitVTable
    
    Dim this As SEnumVARIANT
    With this
        .VTablePtr = VarPtr(VTable(0))
        .References = 1
        Set .Iterator = Iterator
    End With
    
    Set New_Enumerator = CreateComEnumerator(VarPtr(this), LenB(this))


End Function


'* @fn Private Function IUnknown_QueryInterface(ByRef this As SEnumVARIANT, ByVal RIid As LongPtr, ByVal ppvObject As LongPtr) As Long
'* @brief COMオブジェクト対してインターフェイスの照会を行います。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @param[in] RIid 照会されているインターフェースのIIDへの参照。
'* @param[in] ppvObject riidパラメーターで指定されたIIDを持つインターフェースへのポインターのアドレス。
'* @return ppvObjectがNULLならE_POINTER、照会されているインタフェースを実装している場合はS_OK、それ以外の場合はE_NOINTERFACEを返します。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/unknwn/nf-unknwn-iunknown-queryinterface(refiid_void)
'*
Private Function IUnknown_QueryInterface(ByRef this As SEnumVARIANT, ByVal RIid As LongPtr, ByVal ppvObject As LongPtr) As Long
    If ppvObject = NUL Then
        IUnknown_QueryInterface = E_POINTER
        Exit Function
    End If

    If Not (RIidIsIEnumerator(RIid)) Then
        IUnknown_QueryInterface = E_NOINTERFACE
        Exit Function
    End If
    
    UnsafeSet(ppvObject) = VarPtr(this)
    Call IUnknown_AddRef(this)
    IUnknown_QueryInterface = S_OK
    
End Function


'* @fn Private Function IUnknown_AddRef(ByRef this As IteratorMemberr) As LongLong
'* @brief COMオブジェクトへのインターフェイスポインタの参照カウントをインクリメントします。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @return 新しい参照カウントを返します。この値は、テスト目的でのみ使用することを目的としています。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/unknwn/nf-unknwn-iunknown-addref
'*
#If Win64 Then
    Private Function IUnknown_AddRef(ByRef this As SEnumVARIANT) As LongLong
        
        'InterlockedIncrement64がkernel32.dllで見付からないため、スレッドアンセーフ状態で参照カウントをインクリメント
        'IUnknown_AddRef = InterlockedIncrement64(this.References)
        this.References = this.References + 1
        IUnknown_AddRef = this.References
    End Function

#Else
    Private Function IUnknown_AddRef(ByRef this As SEnumVARIANT) As Long
        'スレッドセーフ状態で参照カウントをインクリメント
        IUnknown_AddRef = InterlockedIncrement(this.References)
    End Function
#End If


'* @fn Private Function IUnknown_Release(ByRef this As IteratorMemberr) As LongLong
'* @brief COMオブジェクトのインターフェイスの参照カウントを減らします。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @return 新しい参照カウントを返します。この値は、テスト目的でのみ使用することを目的としています。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/unknwn/nf-unknwn-iunknown-Release
'*
#If Win64 Then
    Private Function IUnknown_Release(ByRef this As SEnumVARIANT) As LongLong
    
        'InterlockedDecrement64がkernel32.dllで見付からないため、スレッドアンセーフ状態で参照カウントをデクリメント
        'IUnknown_Release = InterlockedDecrement64(this.References)
        this.References = this.References - 1
        IUnknown_Release = this.References
        
        '参照カウントが0になったらインスタンスのメモリを解放
        If (IUnknown_Release = 0) Then
            Set this.Iterator = Nothing
            Call CoTaskMemFree(VarPtr(this))
        End If
        
    End Function

#Else
    Private Function IUnknown_Release(ByRef this As SEnumVARIANT) As Long
        
        'スレッドセーフ状態で参照カウントをデクリメント
        IUnknown_Release = InterlockedDecrement(this.References)
        
        '参照カウントが0になったらインスタンスのメモリを解放
        If (IUnknown_Release = 0) Then
            Set this.Iterator = Nothing
            Call CoTaskMemFree(VarPtr(this))
        End If
        
    End Function

#End If




'* @fn Private Function IEnumVARIANT_Next(ByRef this As IteratorMemberr, ByVal celt As Long, ByRef rgVar As EnumVariables, ByRef pCeltFetched As Long) As Long
'* @brief 列挙シーケンスで指定された要素を取得します。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @param[in] celt 取得する要素の数
'* @param[out] rgVar 取得した要素を返す配列(をメンバに持つ構造体)。
'* @param[out] pCeltFetched NULL参照でない場合、rgVarで返した要素の数を返します。
'* @return 返される要素の数がceltと同じ場合はS_OK、返される要素の数がcelt未満の場合はS_FALSEを返します。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/oaidl/nf-oaidl-ienumvariant-next
'*
Private Function IEnumVARIANT_Next(ByRef this As SEnumVARIANT, ByVal celt As Long, ByRef rgVar As EnumVariables, ByRef pCeltFetched As Long) As Long
    
    If (VarPtr(rgVar.Element(0)) = NUL) Then
        IEnumVARIANT_Next = E_POINTER
        Exit Function
    End If

    Dim Fetched As Long
    Do While (this.Iterator.GetNext(rgVar.Element(Fetched)))
        
        Fetched = Fetched + 1
        If (Fetched = celt) Then
            If VarPtr(pCeltFetched) Then pCeltFetched = Fetched
           IEnumVARIANT_Next = S_OK
            Exit Function
        End If
    Loop

    If VarPtr(pCeltFetched) Then pCeltFetched = Fetched
    IEnumVARIANT_Next = S_FALSE

End Function


'* @fn Private Function IEnumVARIANT_Skip(ByRef this As SEnumVARIANT, ByVal celt As Long) As Long
'* @brief 列挙シーケンス内の要素をスキップしようとします。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @param[in] celt スキップする要素の数
'* @return 指定された要素数をスキップした場合はS_OK、要求された数の要素をスキップする前に最後の要素に到達した場合はS_FALSEを返します。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/oaidl/nf-oaidl-ienumvariant-skip
'*
Private Function IEnumVARIANT_Skip(ByRef this As SEnumVARIANT, ByVal celt As Long) As Long
    
    With this.Iterator
        Dim e As Variant
        Dim i As Long
        For i = 1 To celt
            If Not (.GetNext(e)) Then
                IEnumVARIANT_Skip = S_FALSE
                Exit Function
            End If
        Next
    End With
    
    IEnumVARIANT_Skip = S_OK
End Function


'* @fn Private Function IEnumVARIANT_Reset(ByRef this As SEnumVARIANT) As Long
'* @brief 列挙シーケンスを最初にリセットします。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @return 関数が成功した場合はS_OK、失敗した場合はS_FALSEを返します。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/oaidl/nf-oaidl-ienumvariant-reset
'*
Private Function IEnumVARIANT_Reset(ByRef this As SEnumVARIANT) As Long
    If (this.Iterator.Reset) Then
        IEnumVARIANT_Reset = S_OK
    Else
        IEnumVARIANT_Reset = S_FALSE
    End If
End Function



'* @fn Private Function IEnumVARIANT_Reset(ByRef this As SEnumVARIANT) As Long
'* @brief (未実装)列挙シーケンスを最初にリセットします。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @param[out] pEnum 複製したCOMオブジェクトへのポインタ
'* @return 関数が成功した場合はS_OK、メモリ不足により失敗した場合はE_OUTOFMEMORYを返します。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/oaidl/nf-oaidl-ienumvariant-clone
'*
Private Function IEnumVARIANT_Clone(ByRef this As SEnumVARIANT, ByRef pEnum As LongPtr) As Long
    IEnumVARIANT_Clone = E_OUTOFMEMORY
End Function

標準モジュールを新規追加し、名前をMArrayEnumeratorに変更して、下記のコードを貼り付けます。

' [VBA]VBＡ単独でFor Eachに対応した自作クラスを作成する方法(64bit Excel対応) 
' Copyright (c) 2020-2024  黒箱 
' This software is released under the GPLv3. 
' このソフトウェアはGNU GPLv3の下でリリースされています。 

'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
' @file           MArrayEnumerator
' @brief          Variant型配列用のIEnumVARIANTを生成するための関数
' @date           2020.11.15
' $Version:       1
' $Revision:      0
' @note           カスタムクラス設計者はNew_VariantArrayEnumerator()を呼び出すだけ列挙子を生成できます。
'
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////


Option Explicit

Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal pv As LongPtr)
#If Win64 Then
'    '下記APIが見付からないためコメントアウト
'    Public Declare PtrSafe Function InterlockedIncrement64 Lib "kernel32" (ByRef lpAddend As LongLong) As LongLong
'    Public Declare PtrSafe Function InterlockedDecrement64 Lib "kernel32" (ByRef lpAddend As LongLong) As LongLong
#Else
    Private Declare PtrSafe Function InterlockedIncrement Lib "kernel32" (ByRef Addend As Long) As Long
    Private Declare PtrSafe Function InterlockedDecrement Lib "kernel32" (ByRef Addend As Long) As Long
#End If


Private Const NUL As LongPtr = 0

'EnumVARIANTのメンバ
Private Type SEnumVARIANT
    VTablePtr    As LongPtr
    References   As LongPtr
    Elements()   As Variant
    CurrentIndex As Long
    FirstIndex   As Long
    LastIndex    As Long
End Type


'VTable
Private VTable(6) As LongPtr


'* @fn Private Sub InitVTable()
'* @brief IEnumVariant用の仮想関数テーブルを初期化します。
'*
Private Sub InitVTable()
    VTable(0) = GetAddressOf(AddressOf IUnknown_QueryInterface)
    VTable(1) = GetAddressOf(AddressOf IUnknown_AddRef)
    VTable(2) = GetAddressOf(AddressOf IUnknown_Release)
    VTable(3) = GetAddressOf(AddressOf IEnumVARIANT_Next)
    VTable(4) = GetAddressOf(AddressOf IEnumVARIANT_Skip)
    VTable(5) = GetAddressOf(AddressOf IEnumVARIANT_Reset)
    VTable(6) = GetAddressOf(AddressOf IEnumVARIANT_Clone)
End Sub


'* @fn Public Function New_VariantArrayEnumerator(ByRef Elements() As Variant, Optional ByVal FirstIndex As Variant, Optional ByVal LastIndex As Variant) As IEnumVARIANT
'* @brief ForEach内でVariant型配列を列挙可能なCOMオブジェクトを生成します。
'* @param[in] Elements ForEachで列挙する配列を指定します。
'* @param[in] FirstIndex 列挙する要素の最初のインデックスを指定します。省略するとLBound(Elements)が指定されます。
'* @param[in] LastIndex 列挙する要素の最後のインデックスを指定します。省略するとUBound(Elements)が指定されます。
'* @return IEnumVARIANTインターフェイスを持つCOMオブジェクトを返します。
'*
Public Function New_VariantArrayEnumerator(ByRef Elements() As Variant, Optional ByVal FirstIndex As Variant, Optional ByVal LastIndex As Variant) As IEnumVARIANT
    If (VTable(0) = NUL) Then Call InitVTable
    
    If (IsMissing(FirstIndex)) Then FirstIndex = LBound(Elements)
    If (IsMissing(LastIndex)) Then LastIndex = UBound(Elements)
    
    Dim this As SEnumVARIANT
    With this
        .VTablePtr = VarPtr(VTable(0))
        .References = 1
        .Elements = Elements
        .FirstIndex = CLng(FirstIndex)
        .CurrentIndex = .FirstIndex
        .LastIndex = CLng(LastIndex)
    End With
    
    Set New_VariantArrayEnumerator = CreateComEnumerator(VarPtr(this), LenB(this))


End Function


'* @fn Private Function IUnknown_QueryInterface(ByRef this As SEnumVARIANT, ByVal RIid As LongPtr, ByVal ppvObject As LongPtr) As Long
'* @brief COMオブジェクト対してインターフェイスの照会を行います。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @param[in] RIid 照会されているインターフェースのIIDへの参照。
'* @param[in] ppvObject riidパラメーターで指定されたIIDを持つインターフェースへのポインターのアドレス。
'* @return ppvObjectがNULLならE_POINTER、照会されているインタフェースを実装している場合はS_OK、それ以外の場合はE_NOINTERFACEを返します。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/unknwn/nf-unknwn-iunknown-queryinterface(refiid_void)
'*
Private Function IUnknown_QueryInterface(ByRef this As SEnumVARIANT, ByVal RIid As LongPtr, ByVal ppvObject As LongPtr) As Long
    If ppvObject = NUL Then
        IUnknown_QueryInterface = E_POINTER
        Exit Function
    End If

    If Not (RIidIsIEnumerator(RIid)) Then
        IUnknown_QueryInterface = E_NOINTERFACE
        Exit Function
    End If

    UnsafeSet(ppvObject) = VarPtr(this)
    Call IUnknown_AddRef(this)
    IUnknown_QueryInterface = S_OK

End Function


'* @fn Private Function IUnknown_AddRef(ByRef this As SEnumVARIANT) As LongLong
'* @brief COMオブジェクトへのインターフェイスポインタの参照カウントをインクリメントします。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @return 新しい参照カウントを返します。この値は、テスト目的でのみ使用することを目的としています。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/unknwn/nf-unknwn-iunknown-addref
'*
#If Win64 Then
    Private Function IUnknown_AddRef(ByRef this As SEnumVARIANT) As LongLong
        'InterlockedIncrement64がkernel32.dllで見付からないため、スレッドアンセーフ状態で参照カウントをインクリメント
        'IUnknown_AddRef = InterlockedIncrement64(this.References)
        this.References = this.References + 1
        IUnknown_AddRef = this.References
    End Function
    
#Else
    Private Function IUnknown_AddRef(ByRef this As SEnumVARIANT) As Long
        'スレッドセーフ状態で参照カウントをインクリメント
        IUnknown_AddRef = InterlockedIncrement(this.References)
    End Function
#End If


'* @fn Private Function IUnknown_Release(ByRef this As SEnumVARIANT) As LongLong
'* @brief COMオブジェクトのインターフェイスの参照カウントを減らします。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @return 新しい参照カウントを返します。この値は、テスト目的でのみ使用することを目的としています。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/unknwn/nf-unknwn-iunknown-Release
'*
#If Win64 Then
    Private Function IUnknown_Release(ByRef this As SEnumVARIANT) As LongLong
    
        'InterlockedDecrement64がkernel32.dllで見付からないため、スレッドアンセーフ状態で参照カウントをデクリメント
        'IUnknown_Release = InterlockedDecrement64(this.References)
        this.References = this.References - 1
        IUnknown_Release = this.References
        
        '参照カウントが0になったらインスタンスのメモリを解放
        If (IUnknown_Release = 0) Then
            Erase this.Elements
            Call CoTaskMemFree(VarPtr(this))
        End If
        
    End Function

#Else
    Private Function IUnknown_Release(ByRef this As SEnumVARIANT) As Long
        
        'スレッドセーフ状態で参照カウントをデクリメント
        IUnknown_Release = InterlockedDecrement(this.References)
        
        '参照カウントが0になったらインスタンスのメモリを解放
        If (IUnknown_Release = 0) Then
            Erase this.Elements
            Call CoTaskMemFree(VarPtr(this))
        End If
        
    End Function

#End If


'* @fn Private Function IEnumVARIANT_Next(ByRef this As SEnumVARIANT, ByVal celt As Long, ByRef rgVar As EnumVariables, ByRef pCeltFetched As Long) As Long
'* @brief 列挙シーケンスで指定された要素を取得します。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @param[in] celt 取得する要素の数
'* @param[out] rgVar 取得した要素を返す配列(をメンバに持つ構造体)。
'* @param[out] pCeltFetched NULL参照でない場合、rgVarで返した要素の数を返します。
'* @return 返される要素の数がceltと同じ場合はS_OK、返される要素の数がcelt未満の場合はS_FALSEを返します。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/oaidl/nf-oaidl-ienumvariant-next
'*
Private Function IEnumVARIANT_Next(ByRef this As SEnumVARIANT, ByVal celt As Long, ByRef rgVar As EnumVariables, ByRef pCeltFetched As Long) As Long
    
    If (VarPtr(rgVar.Element(0)) = NUL) Then
        IEnumVARIANT_Next = E_POINTER
        Exit Function
    End If

    Dim Fetched As Long
    Do While (this.CurrentIndex <= this.LastIndex)
    
        If (IsObject(this.Elements(this.CurrentIndex))) Then
            Set rgVar.Element(Fetched) = this.Elements(this.CurrentIndex)
        Else
            rgVar.Element(Fetched) = this.Elements(this.CurrentIndex)
        End If
        
        this.CurrentIndex = this.CurrentIndex + 1
        Fetched = Fetched + 1
        
        If (Fetched = celt) Then
            If VarPtr(pCeltFetched) Then pCeltFetched = Fetched
           IEnumVARIANT_Next = S_OK
            Exit Function
        End If
    Loop

    If VarPtr(pCeltFetched) Then pCeltFetched = Fetched
    
    IEnumVARIANT_Next = S_FALSE

End Function


'* @fn Private Function IEnumVARIANT_Skip(ByRef this As SEnumVARIANT, ByVal celt As Long) As Long
'* @brief 列挙シーケンス内の要素をスキップしようとします。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @param[in] celt スキップする要素の数
'* @return 指定された要素数をスキップした場合はS_OK、要求された数の要素をスキップする前に最後の要素に到達した場合はS_FALSEを返します。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/oaidl/nf-oaidl-ienumvariant-skip
'*
Private Function IEnumVARIANT_Skip(ByRef this As SEnumVARIANT, ByVal celt As Long) As Long
    this.CurrentIndex = this.CurrentIndex + celt
    IEnumVARIANT_Skip = S_OK
End Function


'* @fn Private Function IEnumVARIANT_Reset(ByRef this As SEnumVARIANT) As Long
'* @brief 列挙シーケンスを最初にリセットします。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @return 関数が成功した場合はS_OK、失敗した場合はS_FALSEを返します。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/oaidl/nf-oaidl-ienumvariant-reset
'*
Private Function IEnumVARIANT_Reset(ByRef this As SEnumVARIANT) As Long
    this.CurrentIndex = this.FirstIndex
    IEnumVARIANT_Reset = S_OK
End Function


'* @fn Private Function IEnumVARIANT_Reset(ByRef this As SEnumVARIANT) As Long
'* @brief (未実装)列挙シーケンスを最初にリセットします。
'* @param[in] this COMオブジェクトへのthisポインタ
'* @param[out] pEnum 複製したCOMオブジェクトへのポインタ
'* @return 関数が成功した場合はS_OK、メモリ不足により失敗した場合はE_OUTOFMEMORYを返します。
'* @details https://docs.microsoft.com/en-us/windows/win32/api/oaidl/nf-oaidl-ienumvariant-clone
'*
Private Function IEnumVARIANT_Clone(ByRef this As SEnumVARIANT, ByRef pEnum As LongPtr) As Long
    IEnumVARIANT_Clone = E_OUTOFMEMORY
End Function

For Eachに指定可能なクラスの作成

IIteratorインターフェイスを使用した実装

クラスモジュールを新規追加し、名前をIIteratorに変更して、下記のコードを貼り付けます。このクラス(インターフェイス)は、他の自作クラスにImplementsし、For Eachでどのようにデータを列挙するかを定義するために使用します。

' [VBA]VBＡ単独でFor Eachに対応した自作クラスを作成する方法(64bit Excel対応) 
' Copyright (c) 2020-2024  黒箱 
' This software is released under the GPLv3. 
' このソフトウェアはGNU GPLv3の下でリリースされています。 

'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
' @file           IIterator
' @brief          New_Enumerator()に渡すクラスが実装すべきインターフェイスを定義します。
' @date           2020.11.15
' $Version:       1
' $Revision:      0
' @note           なし
'
'///////////
Option Explicit


'* @fn Public Function GetNext(ByRef e As Variant) As Boolean
'* @brief 次の要素を取得します。
'* @param[out] e 取得した要素を格納します。
'* @return 次の要素を取得したらTrue、次の要素を取得できなかった場合はFalseを返します。
'* @details
'*
Public Function GetNext(ByRef e As Variant) As Boolean
End Function


'* @fn Public Function Reset() As Boolean
'* @brief 列挙子を初期状態に戻します(おそらくFor Eachから呼び出されることはありません)
'* @return 関数が成功したらTrue、それ以外はFalseを返します。
'*
Public Function Reset() As Boolean
End Function

では、実際にImplementsしてみましょう。クラスモジュールを新規追加し、名前をStringIteratorに変更して、下記のコードを貼り付けます。2行目の「Implements IIterator」で、先程定義したインターフェイスをImplementsしています。IIterator_GetNext()はForEachのループ1回毎に呼び出されます。IIterator_GetNext()がTrueを返す間はループを回り続け、Falseを返したタイミングでループを抜けます。なお、IIterator_Reset()はForEachから呼び出されることは無いと思いますので、実装しなくても動作に影響はありませんが、可能であれば実装しておきましょう。

' [VBA]VBＡ単独でFor Eachに対応した自作クラスを作成する方法(64bit Excel対応) 
' Copyright (c) 2020-2024  黒箱 
' This software is released under the GPLv3. 
' このソフトウェアはGNU GPLv3の下でリリースされています。 

Option Explicit
Implements IIterator

Private s As String
Private i As Long
Private Length As Long

'コンストラクタ
Friend Sub Construct(Target As String)
    s = Target
    i = 1
    Length = Len(s)
End Sub

Private Function IIterator_GetNext(e As Variant) As Boolean
        
    '最後の要素を返した後に、再びGetNext()が呼ばれたタイミングでFor Each終了
    If (Length < i) Then
        IIterator_GetNext = False '要素の取得に失敗したことを通知
        Exit Function
    End If
    
    '1文字返す
    e = Mid(s, i, 1)
    i = i + 1
    
    IIterator_GetNext = True '要素の取得に成功したことを通知
    
End Function

Private Function IIterator_Reset() As Boolean
    '要素の位置を先頭に戻す
    i = 1
    IIterator_Reset = True
End Function

それでは、StringIteratorを使用して任意のクラスをForEachに対応させてましょう。

クラスモジュールを新規追加し、名前をMyStringに変更して、下記のコードを貼り付けます。なお、7行目及び17~18行目がエラーとなりますが、無視してコードを保存します。次に、MyStringクラスモジュールを解放します。解放する際にエクスポートするか確認されるため、適当な場所にエクスポートして下さい。エクスポートしたファイルを再び同じブックにインポートして下さい。先程エラーが発生していた行が消えていれば成功です。

' [VBA]VBＡ単独でFor Eachに対応した自作クラスを作成する方法(64bit Excel対応) 
' Copyright (c) 2020-2024  黒箱 
' This software is released under the GPLv3. 
' このソフトウェアはGNU GPLv3の下でリリースされています。 

Option Explicit

Private s As String

'デフォルトプロパティ
Public Property Get Str() As String
Attribute Value.VB_UserMemId = 0
'Attribute Value.VB_UserMemId = 0
    Str = s
End Property

Public Property Let Str(RHS As String)
    s = RHS
End Property

Public Function NewEnum() As IEnumVARIANT
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
'Attribute NewEnum.VB_UserMemId = -4
'Attribute NewEnum.VB_MemberFlags = "40"
    
    Dim ite As New StringIterator
    Call ite.Construct(s)
    
    Set NewEnum = New_Enumerator(ite)
End Function

いよいよ、カスタムクラスFor Eachで列挙してみます。標準モジュールを新規追加し、名前をEnumTestに変更して、下記のコードを貼り付けます。MyStringTest()内でF5を押してコードを実行すると、イミディエイトウィンドウに指定した文字列が1文字ずつ表示されるかと思います。

' [VBA]VBＡ単独でFor Eachに対応した自作クラスを作成する方法(64bit Excel対応) 
' Copyright (c) 2020-2024  黒箱 
' This software is released under the GPLv3. 
' このソフトウェアはGNU GPLv3の下でリリースされています。 

'カスタム列挙子のテスト用関数です。実行するとMyString内のメンバ変数の文字列を1文字ずつ列挙します。
Private Sub MyStringTest()

    Dim s As New MyString
    s = "abc壱弐参"
    
    Dim i As Long
    Dim e As Variant
    For Each e In s
        i = i + 1
        Debug.Print i & ":" & e
    Next

End Sub

クラス内の配列を列挙する実装

IIteratorインターフェイスによる実装は自由度が高いため、本来はこれ1つあれば全てのデータ構造に対応可能です。しかし、余分なクラスを定義せずに手軽にFor Eachに対応したいというニーズのために、PrivateなVariant型配列をIIteratorインターフェイスなしで回せるコードを書いておきました。最初の方で作成したMArrayEnumeratorがそれです。

クラスモジュールを新規追加し、名前をMyArrayに変更して、下記のコードを貼り付けます。なお、7行目及び28~29行目がエラーとなりますが、無視してコードを保存します。次に、MyArrayクラスモジュールを解放します。解放する際にエクスポートするか確認されるため、適当な場所にエクスポートして下さい。エクスポートしたファイルを再び同じブックにインポートして下さい。先程エラーが発生していた行が消えていれば成功です。

' [VBA]VBＡ単独でFor Eachに対応した自作クラスを作成する方法(64bit Excel対応) 
' Copyright (c) 2020-2024  黒箱 
' This software is released under the GPLv3. 
' このソフトウェアはGNU GPLv3の下でリリースされています。 

Option Explicit

Private ary() As Variant

'デフォルトプロパティ
Public Property Get Item(ByVal i As Long) As Variant
Attribute Value.VB_UserMemId = 0
'Attribute Value.VB_UserMemId = 0
    If (IsObject(ary(i))) Then
        Set Item = ary(i)
    Else
        Item = ary(i)
    End If
    
End Property

Public Property Let Item(ByVal i As Long, RHS As Variant)
    ary(i) = RHS
End Property

Public Property Set Item(ByVal i As Long, RHS As Variant)
    Set ary(i) = RHS
End Property


'列挙子を生成
Public Function NewEnum() As IEnumVARIANT
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
'Attribute NewEnum.VB_UserMemId = -4
'Attribute NewEnum.VB_MemberFlags = "40"
    Set NewEnum = New_VariantArrayEnumerator(ary)
End Function


'要素数を返す
Public Property Get Count() As Long
    Count = UBound(ary)
End Property

'要素数を変更
Public Sub Resize(ByVal Size As Long)
    ReDim Preserve ary(1 To Size)
End Sub


'コンストラクタ
Private Sub Class_Initialize()
    ReDim ary(1 To 1)
End Sub

MyArrayクラスのインスタンをFor Eachで列挙してみます。EnumTest標準モジュールに下記のコードを追加で貼り付けます。MyArrayTest()内でF5を押してコードを実行すると、イミディエイトウィンドウにMyClass内の要素が1つずつ表示されれば成功です。

' [VBA]VBＡ単独でFor Eachに対応した自作クラスを作成する方法(64bit Excel対応) 
' Copyright (c) 2020-2024  黒箱 
' This software is released under the GPLv3. 
' このソフトウェアはGNU GPLv3の下でリリースされています。 


'配列用のカスタム列挙子のテスト用関数です。実行するとMyArrayのプライベート配列を列挙します。
Private Sub MyArrayTest()

    Dim c As New MyArray
    Dim e As Variant
    
    Call c.Resize(9)
    Dim i As Long
    For i = 1 To 9
        c(i) = i & ":" & Rnd()
    Next
    

    For Each e In c
        Debug.Print e
    Next
    
End Sub

おわりに

いかがだったでしょうか？VBA開発が中規模以上になってくると、複雑なデータ構造を取り扱う場面が多くなってくると思います(VBAで規模の大きい開発をするなというツッコミはなしで)。この際、ループ構造が2重、3重になってくるとコードの可読性が低下し、保守性が悪くなってきます。そんな時、データ構造をクラス内に隠蔽したいところですが、VBAの標準機能ではカスタムクラスをForEachで回せないため、敢え無く失敗してしまいます(インターフェイスかCallByNameで内部イテレータという手段もありますが)。そのような辛酸を舐め尽くした全てのVBAプログラマのために、本記事を執筆しました。

なお、今回紹介したコードの内、ForEachの実装に最低限必要なモジュールは下記の通りです。

MEnumerator
MEnumeratorBase
IIterator

MArrayEnumeratorは、必要に応じて追加して下さい。

繰り返しになりますが、ウィルス対策ソフトの種類によってはForEachが遅くなりますので注意して下さい。

さて、そろそろ64bit版Excelへ移行するニーズもあるかと思い、今回はExcel2010以降の32bit/64bit共用のコードを書きました。1点気掛かりなのが、64bit版コードはCOMの参照カウント増減がスレッドセーフではありません。というのも、InterlockedIncrement64がWindowsRTにしか対応していないようで、かつInterlockedIncrementが64bit版kernel32.dllに含まれていませんでした。まぁ、メモリ上に作成した(シングルスレッドの)VBA上でのみ走っているCOMオブジェクトに、スレッドセーフ対応が必要か疑問が残る所なので、実害は無いでしょう。しかし32bit版と64bit版で実装が違うのは気持ち悪いので、解決方法を見付けたら直します。何か情報をお持ちお方、ご連絡いただけると幸いです。

プログラムの利用について

本プログラムのライセンスは「GPL-3.0(GNU General Public License version 3)」を適用しています。

本プログラムを私的に利用(個人利用、並びに企業またはその他の組織の内部利用)される方は、本プログラムを無償で利用できると考えて差し支え御座いません。その場合でも、本プログラム内の著作権及びライセンスの表示は削除せずに表示しておいて下さい。

その他の方は、GNU 一般公衆利用許諾書（GNU GENERAL PUBLIC LICENSE）バージョン3の内容をご理解頂き、適正な利用をお願い致します。同ライセンス以外での利用をご希望の方はお問い合わせフォームよりご連絡下さい。

本ホームページのプログラムを書籍またはホームページ等で一般公開したい方は、お問い合わせフォームよりご連絡下さい。

VBAGPLv3,ソースコード

Posted by 黒箱