In my own projects I use a typelib and a custom interface to do the same thing, (comparable to .NET and Olaf's examples) which might seem overly complex, so here's an example that gets the job done without any dependencies. It also serves as a good example of creating a Lightweight COM Object that's less complex than Curland's examples (which are always over-complicated). It should be easy enough to adapt to your own custom collections.
Code:
' Copyright © 2017 Dexter Freivald. All Rights Reserved. DEXWERX.COM
'
' MEnumerator.bas
'
' Implementation of IEnumVARIANT to support For Each in VB6
'
Option Explicit
Private Type TENUMERATOR
VTablePtr As Long
References As Long
Enumerable As Object
Index As Long
Upper As Long
Lower As Long
End Type
Private Enum API
NULL_ = 0
S_OK = 0
S_FALSE = 1
E_NOTIMPL = &H80004001
E_NOINTERFACE = &H80004002
E_POINTER = &H80004003
#If False Then
Dim NULL_, S_OK, S_FALSE, E_NOTIMPL, E_NOINTERFACE, E_POINTER
#End If
End Enum
Private Declare Function FncPtr Lib "msvbvm60" Alias "VarPtr" (ByVal FunctionAddress As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function CopyBytesZero Lib "msvbvm60" Alias "__vbaCopyBytesZero" (ByVal Length As Long, Dst As Any, Src As Any) As Long
Private Declare Function CoTaskMemAlloc Lib "ole32" (ByVal cb As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal psz As Long, ByVal cblen As Long) As Long
Private Declare Function VariantCopyToPtr Lib "oleaut32" Alias "VariantCopy" (ByVal pvargDest As Long, ByRef pvargSrc As Variant) As Long
Public Function NewEnumerator(ByRef Enumerable As Object, _
ByVal Upper As Long, _
Optional ByVal Lower As Long _
) As IEnumVARIANT
Static VTable(6) As Long
If VTable(0) = NULL_ Then
VTable(0) = FncPtr(AddressOf IUnknown_QueryInterface)
VTable(1) = FncPtr(AddressOf IUnknown_AddRef)
VTable(2) = FncPtr(AddressOf IUnknown_Release)
VTable(3) = FncPtr(AddressOf IEnumVARIANT_Next)
VTable(4) = FncPtr(AddressOf IEnumVARIANT_Skip)
VTable(5) = FncPtr(AddressOf IEnumVARIANT_Reset)
VTable(6) = FncPtr(AddressOf IEnumVARIANT_Clone)
End If
Dim This As TENUMERATOR
With This
.VTablePtr = VarPtr(VTable(0))
.Lower = Lower
.Index = Lower
.Upper = Upper
.References = 1
Set .Enumerable = Enumerable
End With
Dim pThis As Long
pThis = CoTaskMemAlloc(LenB(This))
CopyBytesZero LenB(This), ByVal pThis, This
GetMem4 pThis, NewEnumerator
End Function
Private Function IID$(ByVal riid As Long)
StrRef(IID) = SysAllocStringByteLen(riid, 16&)
End Function
Private Function IID_IUnknown() As String
Static IID As String
If StrPtr(IID) = NULL_ Then
IID = String$(8, vbNullChar)
IIDFromString StrPtr("{00000000-0000-0000-C000-000000000046}"), StrPtr(IID)
End If
IID_IUnknown = IID
End Function
Private Function IID_IEnumVARIANT() As String
Static IID As String
If StrPtr(IID) = NULL_ Then
IID = String$(8, vbNullChar)
IIDFromString StrPtr("{00020404-0000-0000-C000-000000000046}"), StrPtr(IID)
End If
IID_IEnumVARIANT = IID
End Function
Private Function IUnknown_QueryInterface(ByRef This As TENUMERATOR, _
ByVal riid As Long, _
ByVal ppvObject As Long _
) As Long
If ppvObject = NULL_ Then
IUnknown_QueryInterface = E_POINTER
Exit Function
End If
Dim siid As String
siid = IID$(riid)
If siid = IID_IUnknown Or siid = IID_IEnumVARIANT Then
DeRef(ppvObject) = VarPtr(This)
IUnknown_AddRef This
IUnknown_QueryInterface = S_OK
Else
IUnknown_QueryInterface = E_NOINTERFACE
End If
End Function
Private Function IUnknown_AddRef(ByRef This As TENUMERATOR) As Long
With This
.References = .References + 1
IUnknown_AddRef = .References
End With
End Function
Private Function IUnknown_Release(ByRef This As TENUMERATOR) As Long
With This
.References = .References - 1
IUnknown_Release = .References
If .References = 0 Then
Set .Enumerable = Nothing
CoTaskMemFree VarPtr(This)
End If
End With
End Function
Private Function IEnumVARIANT_Next(ByRef This As TENUMERATOR, _
ByVal celt As Long, _
ByVal rgVar As Long, _
ByVal pceltFetched As Long _
) As Long
If rgVar = NULL_ Then
IEnumVARIANT_Next = E_POINTER
Exit Function
End If
Dim Fetched As Long
With This
Do Until .Index > .Upper
VariantCopyToPtr rgVar, .Enumerable(.Index)
.Index = .Index + 1&
Fetched = Fetched + 1&
If Fetched = celt Then Exit Do
rgVar = PtrAdd(rgVar, 16&)
Loop
End With
If pceltFetched Then DLng(pceltFetched) = Fetched
If Fetched < celt Then IEnumVARIANT_Next = S_FALSE
End Function
Private Function IEnumVARIANT_Skip(ByRef This As TENUMERATOR, ByVal celt As Long) As Long
IEnumVARIANT_Skip = E_NOTIMPL
End Function
Private Function IEnumVARIANT_Reset(ByRef This As TENUMERATOR) As Long
IEnumVARIANT_Reset = E_NOTIMPL
End Function
Private Function IEnumVARIANT_Clone(ByRef This As TENUMERATOR, ByVal ppEnum As Long) As Long
IEnumVARIANT_Clone = E_NOTIMPL
End Function
Private Function PtrAdd(ByVal Pointer As Long, ByVal Offset As Long) As Long
PtrAdd = (Pointer Xor &H80000000) + Offset Xor &H80000000
End Function
Private Property Let DeRef(ByVal Address As Long, ByVal Value As Long)
GetMem4 Value, ByVal Address
End Property
Private Property Let DLng(ByVal Address As Long, ByVal Value As Long)
GetMem4 Value, ByVal Address
End Property
Private Property Let StrRef(ByRef Str As String, ByVal Value As Long)
GetMem4 Value, ByVal VarPtr(Str)
End Property