searching through a collection

I have a simple collection which typically holds the following:

HTML Code:

---

Value      Key
125434    J
544334    H

---

All I want to do is to loop through it and look for H and if I find H I want to display 544334.
If there is no match then I want to ignore and break out.

I know this sounds easy but this old VB6 stuff is driving me nutty :-(

This might help.

Code:

---

Public Function ContainsKey(Col As Collection, Key As Variant) As Boolean
On Error Resume Next
    Col.Item Key
    ContainsKey = (Err.Number = 0&)
    Err.Clear
End Function

---

AIR CODE:

Code:

---

Dim MyKey: MyKey = "H"
If ContainsKey(C, MyKey) Then Debug.Print C.Item(MyKey)

---

Is there no For Each in VB6 collections?

Quote:

---

Originally Posted by venerable bede

Is there no For Each in VB6 collections?

---

There is, but you didn't need it to do what you were asking.

Code:

---

   
    Dim MyItem
    For Each MyItem In c
        Debug.Print MyItem
    Next

---

How would I loop through them ?

Quote:

---

Originally Posted by DEXWERX

There is, but you didn't need it to do what you were asking.

Code:

---

   
    Dim MyItem
    For Each MyItem In c
        Debug.Print MyItem
    Next

---

---

Sorry I was too slow

For what you want to do, you don't need to loop.

The ContainsKey checks if an item with the key exists, and the "air code" not only calls it but also gets the value from that item.


While you could do the same with a loop, I'm pretty sure this is a faster option.

Here's my collection routines...

Attachment 135381

Kind of off-topic post:

Note that `ContainsKey` is very inefficient when checked keys are *not* found, because the runtime has to populate `Err` object which is an expensive operation. When the keys are present `ContainsKey` is very performant O(1) hash lookup implementation.

Also note that if you are using `Break on all errors` IDE setting (and you *have to*, particularly on large projects) the `On Error Resume Next` is "ignored" and IDE breaks on the `Item` call.

I'm using a typelib with tweaked `Collection` interface that does not return HRESULT on `Item` and all other methods but a plain `long` so no errors are raised and retval can be checked for S_OK manually.

Code:

---

    [
      odl,
      uuid(A4C46780-499F-101B-BB78-00AA00383CBB),
    ]
    interface IVbCollection  : IUnknown {
        HRESULT GetTypeInfoCount(
            [out, retval] int* pctinfo);

        LONG GetTypeInfo(
            [in] int itinfo,
            [in] long lcid,
            [out] void *pptinfo);

        LONG GetIDsOfNames(
            [in] void *riid,
            [in] LPWSTR *rgszNames,
            [in] int cNames,
            [in] long lcid,
            [out] long *rgdispid);

        LONG Invoke(
            [in] long dispidMember,
            [in] void *riid,
            [in] long lcid,
            [in] short wFlags,
            [in] void *pdispparams,
            [out] VARIANT *pvarResult,
            [out] void *pexcepinfo,
            [out] int *puArgErr);
           
        long Item(
            [in] VARIANT* Index,
            [out, optional] VARIANT* pvarRet);
           
        long Add(
            [in] VARIANT* Item,
            [in, optional] VARIANT* Key,
            [in, optional] VARIANT* Before,
            [in, optional] VARIANT* After);
           
        long Count([out] long* pcRet);
        long Remove([in] VARIANT* Index);
        long NewEnum([out] IUnknown** ppunk);
    };

---

cheers,
</wqw>

Good point and a useful interface definition. I'd probably try to add a "hidden" attribute to NewEnum though.

This goes a long way to removing one advantage of Scripting.Dictionary. Using those adds a dependency (not something I worry about much). But that object also contains performance time bombs, the properties that return entire arrays of values (.Items, .Keys).

Quote:

---

Originally Posted by wqweto

Kind of off-topic post:

Note that `ContainsKey` is very inefficient when checked keys are *not* found, because the runtime has to populate `Err` object which is an expensive operation. When the keys are present `ContainsKey` is very performant O(1) hash lookup implementation.

Also note that if you are using `Break on all errors` IDE setting (and you *have to*, particularly on large projects) the `On Error Resume Next` is "ignored" and IDE breaks on the `Item` call.

I'm using a typelib with tweaked `Collection` interface that does not return HRESULT on `Item` and all other methods but a plain `long` so no errors are raised and retval can be checked for S_OK manually.

Code:

---

    [
      odl,
      uuid(A4C46780-499F-101B-BB78-00AA00383CBB),
    ]
    interface IVbCollection  : IUnknown {
        HRESULT GetTypeInfoCount(
            [out, retval] int* pctinfo);

        LONG GetTypeInfo(
            [in] int itinfo,
            [in] long lcid,
            [out] void *pptinfo);

        LONG GetIDsOfNames(
            [in] void *riid,
            [in] LPWSTR *rgszNames,
            [in] int cNames,
            [in] long lcid,
            [out] long *rgdispid);

        LONG Invoke(
            [in] long dispidMember,
            [in] void *riid,
            [in] long lcid,
            [in] short wFlags,
            [in] void *pdispparams,
            [out] VARIANT *pvarResult,
            [out] void *pexcepinfo,
            [out] int *puArgErr);
           
        long Item(
            [in] VARIANT* Index,
            [out, optional] VARIANT* pvarRet);
           
        long Add(
            [in] VARIANT* Item,
            [in, optional] VARIANT* Key,
            [in, optional] VARIANT* Before,
            [in, optional] VARIANT* After);
           
        long Count([out] long* pcRet);
        long Remove([in] VARIANT* Index);
        long NewEnum([out] IUnknown** ppunk);
    };

---

cheers,
</wqw>

---

I love posts like these. Here's my tweaks. (mostly cosmetic for the IDE)

Code:

---

       
/* VBA.Collection Interface that bypasses VB Runtime Error Checking
    from wqweto http://www.vbforums.com/showthread.php?822115-searching-through-a-collection */
    [uuid(A4C46780-499F-101B-BB78-00AA00383CBB),odl,hidden,helpstring("Collection Interface that bypasses VB Runtime Error Checking")]
    interface ICollection  : IDispatch {
        [id(0)]
        LONG Item(
            [in] VARIANT* Index,
            [out, optional] VARIANT* pvarRet);
           
        LONG Add(
            [in] VARIANT* Item,
            [in, optional] VARIANT* Key,
            [in, optional] VARIANT* Before,
            [in, optional] VARIANT* After);
           
        LONG Count([out] LONG* pcRet);
        LONG Remove([in] VARIANT* Index);
        LONG _NewEnum([out] IUnknown** ppunk);
    };

---

Code:

---

Public Function ContainsKeyFast(Col As Collection, Key As Variant) As Boolean
    Dim ICol As ICollection
    ObjRef(ICol) = ObjRef(Col)  'skip QI/AddRef
    ContainsKeyFast = (ICol.Item(Key) = S_OK)
    ObjRef(ICol) = vbNullPtr
End Function

or maybe...

Public Function ContainsKeyFast(Col As Collection, Key As Variant) As Boolean
    Dim ICol As ICollection
    GetMem4 Col, ICol 'skip QI/AddRef
    ContainsKey = (ICol.Item(Key) = S_OK)
    GetMem4 0&, ICol
End Function

---

@DEXWERX: This looks fast!

In my opinion `ContainsKey` is overrated as functionality, I much prefer to use `TryGet` semantics as implemented on `Dictionary` in .Net -- returns true/false on contains/missing *and* returns the value on success, so no need for a second call to get it. If you don't need it just ignore the optional `RetVal` as it's free performancewise.

Here is my utility function for this

Code:

---

Public Function SearchCollection(ByVal pCol As Object, Index As Variant, Optional RetVal As Variant) As Boolean
    Const DISPID_VALUE  As Long = 0
    Dim pVbCol          As IVbCollection
   
    If pCol Is Nothing Then
        '--- do nothing
    ElseIf TypeOf pCol Is IVbCollection Then
        Set pVbCol = pCol
        SearchCollection = pVbCol.Item(Index, RetVal) = S_OK
    Else
        SearchCollection = DispInvoke(pCol, DISPID_VALUE, ucsIclMethod Or ucsIclPropGet, RetVal:=RetVal, Args:=Index)
    End If
End Function

---

It's not fastest possible implementation but it workds for `ADODB.Fields` collections (or `Printers`) too *and* does not "Break on all errors" in the IDE.

Function `DispInvoke` is complicated one that needs `IVbDispatch` -- another VB-ized interface. It just calls `IDispatch.Invoke` for default prop/method and because it's not known beforehand if DISPID_VALUE is a method or a propget it passes both flags with `ucsIclMethod Or ucsIclPropGet` -- nice hack that Olaf has mentioned here before. Btw, this is what VB6/VBA/VBScript passes on `val = obj.MyMethod` expressions for late-bound calls on `obj` (the assignment is imported, otherwise it positively is a method)

cheers,
</wqw>

That's a great generic function that works with all 'Collections' Thanks for sharing! (ContainsKey/TryGetValue/DispInvoke)

Code:

---

Public Function TryGetValue(Col As Collection, Key As Variant, Optional Value As Variant) As Boolean
    If Col Is Nothing Then Exit Function
    Dim ICol As ICollection
    GetMem4 Col, ICol
    TryGetValue = (ICol.Item(Key, Value) = 0&)
    GetMem4 0&, ICol
End Function

---

Some more tweaks. :bigyello:

Code:

---

Public Function TryGetValue(ByRef Col As ICollection, ByRef Index As Variant, Optional ByRef RetVal As Variant) As Boolean
    Const S_OK = 0&

    If Not Col Is Nothing Then TryGetValue = Col(Index, RetVal) = S_OK
End Function

---

This doesn't work when the collections consists of objects (classes), or am I missing something obvious here?

Can you show your code?

Code:

---

Private Sub Main()
    Dim Col As Collection, sKey As String, RV As Variant

    Set Col = New Collection
    RV = ObjPtr(Col)
    sKey = Hex$(RV)
    Col.Add CLng(RV), sKey

    Debug.Print , "&H"; sKey
    Debug.Print TryGetValue(Col, StrReverse(sKey), RV), "&H"; Hex$(RV)
    Debug.Print TryGetValue(Nothing, sKey, RV), "&H"; Hex$(RV)
    Debug.Print TryGetValue(Col, sKey, RV), "&H"; Hex$(RV)
   
' Added code to test objects in collection
    Dim cClass As Class1
    Set cClass = New Class1
   
    cClass.Key = "Key 1"
    cClass.Description = "Description 1"
   
    Col.Add cClass, cClass.Key
   
    'Set cClass = Nothing
    If TryGetValue(Col, "Key 2", cClass) Then Debug.Print cClass.Description
    If TryGetValue(Col, "Key 1", cClass) Then Debug.Print cClass.Description
   
End Sub

Public Function TryGetValue(ByRef Col As ICollection, ByRef Index As Variant, Optional ByRef RetVal As Variant) As Boolean
    Const S_OK = 0&

    If Not Col Is Nothing Then TryGetValue = Col(Index, RetVal) = S_OK
End Function

---

Class1:

Code:

---

Option Explicit

Public Key As String
Public Description As String

---

Quote:

---

Originally Posted by Arnoutdv

This doesn't work when the collections consists of objects (classes), or am I missing something obvious here?

---

It appears that tweaked method signatures like the following:

Code:

---

long Item([in] VARIANT* Index, [out, optional] VARIANT* pvarRet);

---

somehow prevents a value from being returned to the caller unless the data type passed to the Optional ByRef RetVal As Variant parameter is a Variant.

In other words, if you want to receive a value via that "out" parameter, you must pass a Variant.

Thank for the clarification Bonnie.

Then I would write the TryGetValue() method as follows:

Code:

---

Public Function TryGetValue(ByRef Col As ICollection, ByRef Index As Variant, Optional ByRef RetVal As Variant) As Boolean
  Const S_OK = 0&
  Dim vItem As Variant

  If Not Col Is Nothing Then
    If Col(Index, vItem) = S_OK Then
      TryGetValue = True
      If IsObject(vItem) Then
        Set RetVal = vItem
      Else
        RetVal = vItem
      End If
    End If
  End If
End Function

---

Passing in a Class as a Variant Out Value.

Now that's an interesting, and arguably broken part of the VB6 language. At least Arnoutdv's version works well (and is consistent with the VB6 runtime philosophy - for good or bad). This is how MS would have originally handled the same type of routine. As evidenced by the automatic Setting of the passed Class1 to Out RetVal. *shrugs*

This is a more sane way to express the same thing, and works with Bonnie's version.

Code:

---

   
    Dim vOut As Variant
    Dim cClass As Class1
    Set cClass = New Class1
   
    cClass.Key = "Key 1"
    cClass.Description = "Description 1"
   
    Col.Add cClass, cClass.Key
   
    Dim vOut As Variant
    'Set cClass = Nothing
    If TryGetValue(Col, "Key 2", vOut) Then
        Set cClass = vOut
        Debug.Print cClass.Description
    End If
    If TryGetValue(Col, "Key 1", vOut) Then
        Set cClass = vOut
        Debug.Print cClass.Description
    End If

---

Personally I'll shake my head and just use (a fixed) Arnoutdv's version.

Code:

---

Private Function TryGetValue(ByRef Col As ICollection, ByRef Index As Variant, Optional ByRef Value As Variant) As Boolean
    Const S_OK = 0&
    Dim RetVal
    If Not Col Is Nothing Then
        TryGetValue = Col(Index, RetVal) = S_OK
        If TryGetValue Then
            If IsObject(RetVal) Then
                Set Value = RetVal
            Else
                Value = RetVal
            End If
        Else
            If IsObject(Value) Then
                Set Value = Nothing
            Else
                Value = Empty
            End If
        End If
    End If
End Function

---

More examples of bad code and why an Out Value should match types.

Most languages would just not compile. VB6 seems to let you hang yourself.

Code:

---

    Dim Value As String
    Col.Add "TestString Value 1", "TsKey1"
    Col.Add "TestString Value 2", "TsKey2"
    Col.Add "TestString Value 3", "TsKey3"
    If TryGetValue(Col, "Tskey1", Value) Then Debug.Print "V1"; Value
    If TryGetValue(Col, "Tskey2", Value) Then Debug.Print "V2"; Value
    If TryGetValue(Col, "Tskey3", Value) Then Debug.Print "V3"; Value

---

Quote:

---

Originally Posted by DEXWERX

VB6 seems to let you hang yourself.

---

First, let me admit that the problem is with the interface declaration in the typelib. The retval on `Item` method should be declared *in*/out like this

Code:

---

        LONG Item(
            [in] VARIANT* Index,
            [in, out, optional] VARIANT* pvarRet);

---

for the case of VT_BYREF objects to be handled correctly.

It's really a complicated case of not very well explained COM features here. Usually for a local variant variable when you `Set vTemp = oObj` the target's variant type is set to VT_DISPATCH (0x0009) and `pdispVal` member points to ObjPtr(oObj). For in/out variant parameters things get more complicated when passing objects.

When you call `TryGetValue` with `RetVal` set to a local variable of a reference type (e.g. local `cClass As Class1`) VB6 constructs a temp variant with its type set to VT_DISPATCH *and* VT_BYREF flag set, in which case `pdispVal` member is pointing to VarPtr(cClass) not ObjPtr(cClass) i.e. the variant is not referencing the object but has a pointer to a variable (`cClass`) which in turn is referencing to the object. In this case `Set RetVal = <expr>` actually keeps the VT_BYREF flag and modifies `cClass` through the pointer.

As a nice consequence of this feature is that when passing `cClass` as RetVal out parameter if there was `Set RetVal = New Class1` this would return the new instance in `cClass` in the caller as expected. But if for instance the code was more like `RetVal = Empty : Set RetVal = New Class1` this would *not* be able to modify `cClass` as the `RetVal` variant would lose the pointer to it (and VT_BYREF flag) on the first assignment to `Empty`.

Now enter [out] params on interface methods. VB6 cannot declare/implement such params but it can call methods with them just fine. With [out] attribute VB6 makes sure the actual variable that is passed as [out] parameter is *cleared* before pushing a pointer to it (to prevent leaks) i.e. there is an implicit `RetVal = Empty` just before calling `Item` on the collection as the interface was declared before.

So to reiterate again, the simple fix for this edge case is to modify the `Item` method signature to in/out `RetVal` and cross fingers that nothing is leaking, as clearly the original `VBA.Collection` interface has this parameter as out/retval only. There is a remote possibility that [in] is not expected here, but provided the method actually works, positively there were no shortcuts taken to variant assignments in method implementation.

cheers,
</wqw>

Quote:

---

Originally Posted by wqweto

So to reiterate again, the simple fix for this edge case is to modify the `Item` method signature to in/out `RetVal`

---

It was the first thing I tried - and it didn't help, because the implementors
of the VBA.Collection took the hint from the original interface-def - and
implemented accordingly.

Meaning, they leave the Out-Param alone, in case of a non-existing Key -
but perform a VariantClear on it, when a Key exists, before applying the
new Value.

Quote:

---

Originally Posted by wqweto

... and cross fingers that nothing is leaking, ...

---

Nope, the implementation is correct - performing an (perhaps implicite) VariantClear
instead of just blanking the Variant out with Zeros.

To rule out any "Arg-passing-magic, interpreting the TLB-Interface-Def" on the side
of the VB6-compiler, I wrote a version which works entirely based on pointers -
but the results remain the same.

The implementors of the VBA.Collection took the hint about the "out-param" seriously... ;)

So there's no way around it, other than the two-stage handling as seen in the examples from Arnout/Dex.

For those interested, here's the (RC5-based) TryGet-version which works with
pointers only - not using any TypeLibs (and it's BTW a little bit faster than the
TypeLib-based version when native compiled).

Code:

---

Private Function TryGetValue(Col As Collection, IndexOrKey, Value) As Boolean
Static Args&(0 To 2), pVT&, pArgs&, pItemFunc&, V
  Args(0) = ObjPtr(Col)
  If Args(0) Then 'the Col-instance is alive (not nothing)
    If pItemFunc = 0 Then 'initialize the Pointer to the Item-Method once
      New_c.MemCopy VarPtr(pVT), Args(0), 4 'deref from ObjPtr to VTable
      New_c.MemCopy VarPtr(pItemFunc), pVT + 7 * 4, 4 'deref from VTable+Offs to the Item-method
      Args(2) = VarPtr(V) 'and at this occasion initialize also the two other "statics"...
      pArgs = VarPtr(Args(0)) '...which will not change among calls
    End If

    Args(1) = VarPtr(IndexOrKey)

    If New_c.stdCallDirect(vbLong, pItemFunc, pArgs, 12) = 0 Then
      TryGetValue = True
      If IsObject(V) Then Set Value = V Else Value = V
   
    Else 'the call wasn't successful
      If IsObject(Value) Then Set Value = Nothing Else Value = Empty
    End If
  End If
End Function

---

Olaf

Quote:

---

Originally Posted by Schmidt

It was the first thing I tried - and it didn't help, because the implementors
of the VBA.Collection took the hint from the original interface-def - and
implemented accordingly.

---

Ooops, my bad! You are right it's not working. Poor testing on my side so the in/out hack is not going to fly.

Edit: Btw, this static V might leak a reference as implemented.

Also I would optimize for speed the case when VT_BYREF is not set so that `Item` output directly to `RetVal` like this

Code:

---

        If (PeekInt(VarPtr(RetVal)) And VT_BYREF) = 0 Then
            SearchCollection = pVbCol.Item(Index, RetVal) = S_OK
        ElseIf pVbCol.Item(Index, vItem) = S_OK Then
            SearchCollection = True
            If IsObject(vItem) Then
                Set RetVal = vItem
            Else
                RetVal = vItem
            End If
        End

---

cheers,
</wqw>

Quote:

---

Originally Posted by wqweto

Edit: Btw, this static V might leak a reference as implemented.

---

Not really leaking (because in the next call, a potentially still set reference
in V would be properly cleaned up by the Collection-implementation).

But such a potential reference in V would be "kept alive" (meaning an
outside Object-instance for example would not "die as expected",
in case there's still a reference to it in the static V.

So it would be better to properly clean up V after each successful call, to
avoid this "keeping a ref alive"-behaviour - e.g. by changing the respecitve line to:

Code:

---

  If IsObject(V) Then Set Value = V: Set V=Nothing Else Value = V: V=Empty

---

But that's academic in some way, unless someone writes an ASM-based replacement
for the little RC5-example - which in its current form is only useful for playing around
somewhat easier with the pointer-stuff (for educational purposes, not the real world,
since there's a faster VB-compatible Collection already available in the RC5).

Quote:

---

Originally Posted by wqweto

Also I would optimize for speed the case when VT_BYREF is not set so that `Item` output directly to `RetVal` like this

Code:

---

        If (PeekInt(VarPtr(RetVal)) And VT_BYREF) = 0 Then
            SearchCollection = pVbCol.Item(Index, RetVal) = S_OK
        ElseIf pVbCol.Item(Index, vItem) = S_OK Then
            SearchCollection = True
            If IsObject(vItem) Then
                Set RetVal = vItem
            Else
                RetVal = vItem
            End If
        End

---

---

Yep, good point.

Olaf