Sunday, 30 September 2018

VBA - .NET Interop - System.Collections.HashTable sample code

In the previous post I showed how to call .NET reflection from VBA to get a list of methods of the .NET System.Collections.* classes. I wanted the method list because I felt deprived without the VBA Intellisense. Once I had the HashTable's class's method list (included in listing) I could start to play around and write some sample code against the HashTable class.

I'd like to stop using Scripting.Dictionary (Microsoft Scripting Runtime) and the System.Collections.SortedList pretty much does everything I need so far. The HashTable is another possible substitute but lacks the sorting and indeed the arrival sequence that you get with a Scripting.Dictionary. Because it does not sort IndexOf is not implemented. I suppose HashTable has performance advantages over SortedList.

All 5 of the (non-generic) collection classes are featured in this C# Corner article Overview of Collection, Array List, Hash Table, Sorted List, Stack and Queue .

Sample System.Collections.HashTable code

Option Explicit

'                    Void Add(?,?)
'                    Void Clear()
'                  Object Clone()
'                 Boolean Contains(?)
'                 Boolean ContainsKey(?)
'                 Boolean ContainsValue(?)
'                    Void CopyTo(?,?)
'                 Boolean Equals(?)
'                   Int32 get_Count()
'                 Boolean get_IsFixedSize()
'                 Boolean get_IsReadOnly()
'                 Boolean get_IsSynchronized()
'                  Object get_Item(?)
'             ICollection get_Keys()
'                  Object get_SyncRoot()
'             ICollection get_Values()
'   IDictionaryEnumerator GetEnumerator()
'                   Int32 GetHashCode()
'                    Void GetObjectData(?,?)
'                    Type GetType()
'                    Void OnDeserialization(?)
'                    Void Remove(?)
'                    Void set_Item(?,?)
'               Hashtable Synchronized(?)
'                  String ToString()

Sub Test()

    Dim hashTable As Object  '* this tracks uniqueness
    Set hashTable = CreateObject("System.Collections.HashTable")
    
    '*
    '* load up the sorted list just like a dictionary
    '*
    hashTable.Add "Red", "FF0000"
    hashTable.Add "Green", "00FF00"
    hashTable.Add "Blue", "0000FF"

    '*
    '* getting the Keys or Values to a Variant Array requires an interim step
    '* which we packed into a function below
    '*
    Dim vKeys
    vKeys = hashTableToArray(hashTable, True)
    Debug.Assert vKeys(0) = "Blue"
    Debug.Assert vKeys(1) = "Red"
    Debug.Assert vKeys(2) = "Green"

    Dim vValues
    vValues = hashTableToArray(hashTable, False)
    Debug.Assert vValues(0) = "0000FF"
    Debug.Assert vValues(1) = "FF0000"
    Debug.Assert vValues(2) = "00FF00"
    
    '*
    '* ContainsKey and IndexOfKey
    '* (Scripting.Dictionary only has equiavlent of ContainsKey(), Exists() )
    '*
    Debug.Assert hashTable.ContainsKey("Red")
    Debug.Assert Not hashTable.ContainsKey("Yellow")

    'Debug.Assert hashTable.IndexOfKey("Red") = 2 '* doesn't exist


    '*
    '* ContainsValue and IndexOfValue
    '* (Scripting.Dictionary has neither of these features)
    '*

    Debug.Assert hashTable.ContainsValue("FF0000")
    Debug.Assert Not hashTable.ContainsValue("FFFF00")

    'Debug.Assert hashTable.IndexOfValue("FF0000") = 2 '* doesn't exist

End Sub

Function hashTableToArray(ByVal hashTable As Object, ByVal bKeysOrValue As Boolean)
    '*
    '* getting the Keys or Values (aka Items) to a Variant Array
    '* requires an interim step with a temporary ArrayList
    '*
    
    If Not TypeName(hashTable) = "Hashtable" Then Err.Raise vbObjectError, , "#argument should be a HashTable!"
    
    Dim arrayListValues As Object
    Set arrayListValues = CreateObject("System.Collections.ArrayList")
    If bKeysOrValue Then
        arrayListValues.AddRange hashTable.Keys
    Else
        arrayListValues.AddRange hashTable.Values
    End If
    hashTableToArray = arrayListValues.ToArray()
    
End Function

VBA - .NET Interop - System.Collections.SortedList sample code

In the previous post I showed how to call .NET reflection from VBA to get a list of methods of the .NET System.Collections.* classes. I wanted the method list because I felt deprived without the VBA Intellisense. Once I had the SortedList's class's method list (included in listing) I could start to play around and write some sample code against the SortedList class. Enjoy!

I'd like to stop using Scripting.Dictionary (Microsoft Scripting Runtime) and the System.Collections.SortedList pretty much does everything I need so far. I can get the Keys and Values (aka Items) into an array by writing a helper function which itself uses an System.Collections.ArrayList. In addition the System.Collections.SortedList has extra methods such as ContainsValue, IndexOfKey, IndexofValue which give it more features than a Scripting.Dictionary. Thumbs up for this.

Sample System.Collections.SortedList code

Option Explicit

'                    Void Add(?,?)
'                    Void Clear()
'                  Object Clone()
'                 Boolean Contains(?)
'                 Boolean ContainsKey(?)
'                 Boolean ContainsValue(?)
'                    Void CopyTo(?,?)
'                 Boolean Equals(?)
'                   Int32 get_Capacity()
'                   Int32 get_Count()
'                 Boolean get_IsFixedSize()
'                 Boolean get_IsReadOnly()
'                 Boolean get_IsSynchronized()
'                  Object get_Item(?)
'             ICollection get_Keys()
'                  Object get_SyncRoot()
'             ICollection get_Values()
'                  Object GetByIndex(?)
'   IDictionaryEnumerator GetEnumerator()
'                   Int32 GetHashCode()
'                  Object GetKey(?)
'                   IList GetKeyList()
'                    Type GetType()
'                   IList GetValueList()
'                   Int32 IndexOfKey(?)
'                   Int32 IndexOfValue(?)
'                    Void Remove(?)
'                    Void RemoveAt(?)
'                    Void set_Capacity(?)
'                    Void set_Item(?,?)
'                    Void SetByIndex(?,?)
'              SortedList Synchronized(?)
'                  String ToString()
'                    Void TrimToSize()

Sub Test()

    Dim sortedList As Object  '* this tracks uniqueness
    Set sortedList = CreateObject("System.Collections.SortedList")
    
    '*
    '* load up the sorted list just like a dictionary
    '*
    sortedList.Add "Red", "FF0000"
    sortedList.Add "Green", "00FF00"
    sortedList.Add "Blue", "0000FF"

    '*
    '* getting the Keys or Values to a Variant Array requires an interim step
    '* which we packed into a function below
    '*
    Dim vKeys
    vKeys = SortedListToArray(sortedList, True)
    Debug.Assert vKeys(0) = "Blue"      '* sorted
    Debug.Assert vKeys(1) = "Green"     '* sorted
    Debug.Assert vKeys(2) = "Red"       '* sorted

    Dim vValues
    vValues = SortedListToArray(sortedList, False)
    Debug.Assert vValues(0) = "0000FF"      '* sorted
    Debug.Assert vValues(1) = "00FF00"      '* sorted
    Debug.Assert vValues(2) = "FF0000"      '* sorted
    
    '*
    '* ContainsKey and IndexOfKey
    '* (Scripting.Dictionary only has equiavlent of ContainsKey(), Exists() )
    '*
    Debug.Assert sortedList.ContainsKey("Red")
    Debug.Assert Not sortedList.ContainsKey("Yellow")

    Debug.Assert sortedList.IndexOfKey("Red") = 2 '* not 0 because it is sorted!


    '*
    '* ContainsValue and IndexOfValue
    '* (Scripting.Dictionary has neither of these features)
    '*

    Debug.Assert sortedList.ContainsValue("FF0000")
    Debug.Assert Not sortedList.ContainsValue("FFFF00")

    Debug.Assert sortedList.IndexOfValue("FF0000") = 2 '* not 0 because it is sorted!

End Sub

Function SortedListToArray(ByVal sortedList As Object, ByVal bKeysOrValue As Boolean)
    '*
    '* getting the Keys or Values (aka Items) to a Variant Array
    '* requires an interim step with a temporary ArrayList
    '*
    
    If Not TypeName(sortedList) = "SortedList" Then Err.Raise vbObjectError, , "#argument should be a SortedList!"
    
    Dim arrayListValues As Object
    Set arrayListValues = CreateObject("System.Collections.ArrayList")
    If bKeysOrValue Then
        arrayListValues.AddRange sortedList.GetKeyList
    Else
        arrayListValues.AddRange sortedList.GetValueList
    End If
    SortedListToArray = arrayListValues.ToArray()
    
End Function

Thursday, 27 September 2018

VBA - .NET Interop - System.Collections.ArrayList sample code

In a previous post I showed how to call .NET reflection from VBA to get a list of methods of the .NET System.Collections.* classes. I wanted the method list because I felt deprived without the VBA Intellisense. Once I had the ArrayList's class's method list (included in listing) I could start to play around and write some sample code against the ArrayList class. Enjoy!

Sample System.Collections.ArrayList code

'               ArrayList Adapter(?)
'                   Int32 Add(?)
'                    Void AddRange(?)
'                   Int32 BinarySearch(?)
'                   Int32 BinarySearch(?,?)
'                   Int32 BinarySearch(?,?,?,?)
'                    Void Clear()
'                  Object Clone()
'                 Boolean Contains(?)
'                    Void CopyTo(?)
'                    Void CopyTo(?,?)
'                    Void CopyTo(?,?,?,?)
'                 Boolean Equals(?)
'                   IList FixedSize(?)
'               ArrayList FixedSize_2(?)
'                   Int32 get_Capacity()
'                   Int32 get_Count()
'                 Boolean get_IsFixedSize()
'                 Boolean get_IsReadOnly()
'                 Boolean get_IsSynchronized()
'                  Object get_Item(?)
'                  Object get_SyncRoot()
'             IEnumerator GetEnumerator()
'             IEnumerator GetEnumerator(?,?)
'                   Int32 GetHashCode()
'               ArrayList GetRange(?,?)
'                    Type GetType()
'                   Int32 IndexOf(?)
'                   Int32 IndexOf(?,?)
'                   Int32 IndexOf(?,?,?)
'                    Void Insert(?,?)
'                    Void InsertRange(?,?)
'                   Int32 LastIndexOf(?)
'                   Int32 LastIndexOf(?,?)
'                   Int32 LastIndexOf(?,?,?)
'                   IList ReadOnly(?)
'               ArrayList ReadOnly_2(?)
'                    Void Remove(?)
'                    Void RemoveAt(?)
'                    Void RemoveRange(?,?)
'               ArrayList Repeat(?,?)
'                    Void Reverse()
'                    Void Reverse(?,?)
'                    Void set_Capacity(?)
'                    Void set_Item(?,?)
'                    Void SetRange(?,?)
'                    Void Sort()
'                    Void Sort(?)
'                    Void Sort(?,?,?)
'                   IList Synchronized(?)
'               ArrayList Synchronized_2(?)
'                Object[] ToArray()
'                   Array ToArray(?)
'                  String ToString()
'                    Void TrimToSize()

Sub Test()
    Dim obj As Object
    Set obj = CreateObject("System.Collections.ArrayList")
    obj.Add 20
    obj.Add 16
    obj.Add 12
    obj.Add 8
    obj.Add 4
    Debug.Assert obj.Count() = 5
    Debug.Assert obj.Item(2) = 12
    
    '*
    '* try finding a value in the ArrayList,
    '* we need to call the two argument overload (the one argument version errors)
    '*
    Debug.Assert obj.IndexOf(12, 0) = 2
    
    '*
    '* we can sort the ArrayList
    '*
    obj.Sort
    Debug.Assert obj.Item(0) = 4
    Debug.Assert obj.Item(4) = 20
    
    '*
    '* we can remove an item (cool)
    '*
    Debug.Assert obj.Item(1) = 8
    Debug.Assert obj.Count = 5
    obj.RemoveAt 1
    Debug.Assert obj.Item(1) = 12
    Debug.Assert obj.Count = 4
    
    '*
    '* we can reverse the ArrayList
    '*
    obj.Reverse
    Debug.Assert obj.Item(3) = 4
    Debug.Assert obj.Item(0) = 20
    
    '*
    '* converting to an ordinary array
    '*
    Dim oArray() As Variant
    oArray() = obj.ToArray()
    Debug.Assert oArray(3) = 4
    
End Sub

VBA - .NET Interop - System.Collections.Stack sample code

In the previous post I showed how to call .NET reflection from VBA to get a list of methods of the .NET System.Collections.* classes. I wanted the method list because I felt deprived without the VBA Intellisense. Once I had the Stack's class's method list (included in listing) I could start to play around and write some sample code against the Stack class. Enjoy!

Sample System.Collections.Stack code

'                    Void Clear()
'                  Object Clone()
'                 Boolean Contains(?)
'                    Void CopyTo(?,?)
'                 Boolean Equals(?)
'                   Int32 get_Count()
'                 Boolean get_IsSynchronized()
'                  Object get_SyncRoot()
'             IEnumerator GetEnumerator()
'                   Int32 GetHashCode()
'                    Type GetType()
'                  Object Peek()
'                  Object Pop()
'                    Void Push(?)
'                   Stack Synchronized(?)
'                Object[] ToArray()
'                  String ToString()

Sub Test()
    Dim obj As Object
    Set obj = CreateObject("System.Collections.Stack")
    obj.Push 4
    obj.Push 8
    obj.Push 12
    
    Dim vLoop As Variant
    For Each vLoop In obj
        Debug.Print vLoop
    Next
    
    Debug.Assert obj.Peek = 12
    Debug.Assert obj.Count = 3
    Debug.Assert obj.Pop = 12
    Debug.Assert obj.Count = 2
    Debug.Assert obj.Peek = 8
    Debug.Assert obj.Pop = 8
End Sub

VBA - .NET Interop - System.Collections.Queue sample code

In the previous post I showed how to call .NET reflection from VBA to get a list of methods of the .NET System.Collections.* classes. I wanted the method list because I felt deprived without the VBA Intellisense. Once I had the Queue's class's method list (included in listing) I could start to play around and write some sample code against the Queue class. Enjoy!

Sample System.Collections.Queue code


'                    Void Clear()
'                  Object Clone()
'                 Boolean Contains(?)
'                    Void CopyTo(?,?)
'                  Object Dequeue()
'                    Void Enqueue(?)
'                 Boolean Equals(?)
'                   Int32 get_Count()
'                 Boolean get_IsSynchronized()
'                  Object get_SyncRoot()
'             IEnumerator GetEnumerator()
'                   Int32 GetHashCode()
'                    Type GetType()
'                  Object Peek()
'                   Queue Synchronized(?)
'                Object[] ToArray()
'                  String ToString()
'                    Void TrimToSize()

Sub Test()
    Dim obj As Object
    Set obj = CreateObject("System.Collections.Queue")
    obj.Enqueue 4
    obj.Enqueue 8
    obj.Enqueue 12
    
    Dim vLoop As Variant
    For Each vLoop In obj
        Debug.Print vLoop
    Next
    
    Debug.Assert obj.Peek = 4
    Debug.Assert obj.Count = 3
    Debug.Assert obj.Dequeue = 4
    Debug.Assert obj.Count = 2
    Debug.Assert obj.Peek = 8
    Debug.Assert obj.Dequeue = 8
    Debug.Assert obj.Dequeue = 12
    Debug.Assert obj.Count = 0
End Sub

VBA - .NET Interop - use .NET Reflection in VBA

In absence of missing Intellisense use .NET Reflection in VBA to list methods of .NET classes exposed as COM classes

In the previous post, I showed code that can scan the registry for .NET classes exposed as COM classes that are creatable and reflectable, the latter is required because the Intellisense is not working for these objects (a mystery I will solve later, I promise). In this post I give code that can (partially) call .NET Reflection logic.

Missing (VBA) Intellisense for System.Collection.* classes

In the last post I discovered 5 collection .NET classes I want to experiment with, all of them in the System.Collections.* namespace. They are Queue, Stack, SortedList, ArrayList & HashTable . The lack of Intellisense can be really hampering, I know there is online documentation (the preceding list is hyperlinked to the docs) but I'd like to get a grip with what I have to hand. Luckily, even from VBA, we can (partially) call the .Net reflection logic.

But .NET objects have a GetType() method

The secret is the .Net's Type class which we can get for a .NET exposed COM class instance by calling GetType. The Type class can report on its methods by calling Type.GetMethods(). Each method can reports its number of parameters, though the parameter type is oddly not available (an oversight or perhaps I have yet to understand how it works). Each method can report the type of the return value (which makes the missing parameter type info even more odd).

That the parameter type information is missing is why I call this partially calling reflection.

The problem of Overloads

Putting missing parameter information to one side, the count of parameters is useful in itself because there is an issue with calling overloads from VBA. .Net happily accepts overloads, that is to say, methods with the same number of parameters and the same method name but which differ by the type of the parameters. Overloads are not allowed in COM interfaces and this is one reason why the Intellisense is missing (there is yet another reason about which I will post later, I promise).

So how can VBA, a COM client, call various .Net overloads? The answer is that by convention where an overload occurs one appends a suffix to differentiate. So compare foo(Int32 x) with foo_2(Double x).

All this means we can write code to give a picture of what methods a .Net class will accept. The source code is given below, in advance I give the output of the (partial) reflection on the Queue class which is better than the IDL from OLEView (see Appendix A at the bottom).

'                   Int32 get_Count()
'                 Boolean get_IsSynchronized()
'                  Object get_SyncRoot()
'                  Object Clone()
'                    Void Clear()
'                    Void CopyTo(?,?)
'                    Void Enqueue(?)
'             IEnumerator GetEnumerator()
'                  Object Dequeue()
'                  Object Peek()
'                   Queue Synchronized(?)
'                 Boolean Contains(?)
'                Object[] ToArray()
'                    Void TrimToSize()
'                  String ToString()
'                 Boolean Equals(?)
'                   Int32 GetHashCode()
'                    Type GetType()

The source code listing

The following uses a Scripting.Dictionary and so requires a Tools->Reference to Microsoft Scripting Runtime.

The source has comments to document what is going on so I'll not replicate them here. Instead, to give a brief overview I needed one SortedList to keep track of unique methods so I can spot when to use a suffix and I needed a second SortedList to sort the methods into a nice sorted order. I wanted to keep information together so I defined a type and created an array of those types. Enjoy!

Option Explicit

'Tools -> References -> mscorlib.dll

Private Type udtMethodInfo
    '*
    '* package all the working variables into a type
    '*
    DotNetName As String
    ReturnType As String
    HasReturnType As Boolean
    Params As String
    ComName As String '* can be suffixed to differentiate
    ComNameAndParams As String
    ReportLine As String '* nice pretty format
End Type

'*
'* give ourselves an array of types so we can report
'*
Private mauMethods() As udtMethodInfo

Sub Test()
    Dim obj As Object
    '* Component needs to have Category ID (CATID) of {62C8FE65-4EBB-45E7-B440-6E39B2CDBF29}  .NET Cateogry
    '* ComputerHKEY_CLASSES_ROOTComponent Categories{62C8FE65-4EBB-45e7-B440-6E39B2CDBF29}
    
    Dim sProgId As String
    'sProgId = "System.Collections.ArrayList"
    'sProgId = "System.Collections.Stack"
    'sProgId = "System.Collections.HashTable"
    'sProgId = "System.Collections.SortedList"
    sProgId = "System.Collections.Queue"
    
    DotNetReflection sProgId
End Sub

Sub DotNetReflection(Optional ByVal sProgId As String = "System.Collections.Queue")
    '*
    '* Create a .NET object that is exposed to COM,
    '* Get the .NET Type object which gives reflections,
    '* then print out the interface of methods
    '* because sadly no Intellisense (even if early bound to mscorlib.dll!)
    '*
    
    Dim objDotNet As Object
    Set objDotNet = VBA.CreateObject(sProgId)
    
    Dim sortedUniqueMethods As Object  '* this tracks uniqueness
    Set sortedUniqueMethods = CreateObject("System.Collections.SortedList")

    Dim sortedCOMNamesAndParams As Object  '* this sorts for the final listing
    Set sortedCOMNamesAndParams = CreateObject("System.Collections.SortedList")

    Dim typ As mscorlib.Type
    Set typ = objDotNet.GetType()
    
    Dim mi() As mscorlib.MethodInfo
    mi = typ.GetMethods_2()       <--- good example of a suffixed overload!!!
    
    ReDim mauMethods(0 To UBound(mi)) As udtMethodInfo

    Dim idx As Integer
    For idx = 0 To UBound(mi)
    
        Dim miLoop As MethodInfo
        Set miLoop = mi(idx)
        
        mauMethods(idx).DotNetName = miLoop.Name
        mauMethods(idx).ReturnType = miLoop.ReturnType.Name
        mauMethods(idx).HasReturnType = (mauMethods(idx).ReturnType <> "Void")
        
        mauMethods(idx).Params = ListParameters(miLoop)
    
        Call FindUniqueMethodName(sortedUniqueMethods, sortedCOMNamesAndParams, mauMethods(idx), idx)
        
    Next
    
    '*
    '* so we have all the information in the array, mauMethods(lLookup).  But, instead of printing in arrival sequence
    '* we want to print alphabetical order that's why we have sortedCOMNamesAndParams
    '*
    Dim objValueList As Object
    Set objValueList = sortedCOMNamesAndParams.GetValueList()
    
    Dim lLoop As Long
    For idx = 0 To sortedCOMNamesAndParams.Count - 1
        Dim lLookup As Long
        lLookup = objValueList(idx)
        
        Debug.Print "'" & mauMethods(lLookup).ReportLine
    Next

End Sub

Sub FindUniqueMethodName(ByVal sortedUniqueMethods As Object, ByVal sortedCOMNamesAndParams As Object, _
    ByRef puMethod As udtMethodInfo, ByVal idx As Long)
    
    Dim sSig As String
    sSig = Signature2(puMethod.DotNetName, puMethod)
    
    If Not sortedUniqueMethods.ContainsKey(sSig) Then
        '*
        '* no clash, no overload, easy
        '*
        puMethod.ComName = puMethod.DotNetName
    Else

        '*
        '* we have an overload so now loop through adding suffix until unique
        '*
        Dim lLoop As Long
        For lLoop = 2 To 255
            Dim sSuffixedName As String
            sSuffixedName = puMethod.DotNetName & "_" & CStr(lLoop)
            
            sSig = Signature2(sSuffixedName, puMethod)
            If Not sortedUniqueMethods.ContainsKey(sSig) Then
                puMethod.ComName = sSuffixedName
                
                Exit For '* found one so can quit loop
            End If
        Next lLoop
    
    End If
    
    puMethod.ComNameAndParams = puMethod.ComName & puMethod.Params
    puMethod.ReportLine = PadSpacesRightAlign(puMethod.ReturnType, 24) & " " & puMethod.ComNameAndParams
    
    sortedUniqueMethods.Add sSig, idx
    sortedCOMNamesAndParams.Add puMethod.ComNameAndParams, idx
   
End Sub

Function Signature2(ByVal sName As String, ByRef puMethod As udtMethodInfo) As String
    '*
    '* concatenate attributes to help establish uniqueness or overload
    '*
    Signature2 = CStr(puMethod.HasReturnType) & " " & sName & " " & puMethod.Params
End Function

Function ListParameters(mi As MethodInfo) As String
    '*
    '* sadly, yet to figure out how to get the ParamterType TODO fix that
    '*
    Dim paramInfo() As mscorlib.ParameterInfo
    paramInfo() = mi.GetParameters()
    
    Dim lParamCount As Long
    lParamCount = UBound(paramInfo()) - LBound(paramInfo()) + 1

    Dim sReturn As String

    Dim lParamLoop As Long
    For lParamLoop = LBound(paramInfo()) To UBound(paramInfo())
        
        sReturn = sReturn & VBA.IIf(Len(sReturn) > 0, ",", "") & "?"
    
    Next lParamLoop
    
    ListParameters = "(" & sReturn & ")"

End Function

Function PadSpacesRightAlign(s, n) As String
    '*
    '* this helps align the method listing
    '*
    Dim lLen As Long
    lLen = Len(s)
    Dim n2 As Long
    If lLen > n Then n2 = lLen Else n2 = n
    PadSpacesRightAlign = Right(String(n2, " ") & s, n2)
End Function

Appendix A - Queue Class IDL shows no methods

OLEVIWEW.exe is usually the most revealing when looking for interface definitions, but even here the Queue class's IDL shows no clues as to what methods it supports and that is why there is no VBA Intellisense...

    [ uuid(7F976B72-4B71-3858-BEE8-8E3A3189A651), version(1.0), custom(0F21F359-AB84-41E8-9A78-36D110E6D2F9, "System.Collections.Queue") ]
    coclass Queue {
        [default] interface _Queue;
        interface _Object;
        interface ICollection;
        interface IEnumerable;
        interface ICloneable;
    };

    [ odl, uuid(3A7D3CA4-B7D1-3A2A-800C-8FC2ACFCBDA4), 
      hidden, dual, oleautomation, custom(0F21F359-AB84-41E8-9A78-36D110E6D2F9, "System.Collections.Queue") ]
    interface _Queue : IDispatch {
    };

Monday, 24 September 2018

VBA - .NET - Registry - Finding .NET objects creatable and reflectable from VBA

In this post, I give code that replicates a feature of OLEVIEW.exe (downloadable from the Windows Platform SDK). There are thousands of COM classes registered and it is nice to have categorisation system. In the screenshot below on the left one can see the categories, the top left is the .NET Category (circled in red), there are many other categories but for the moment I am interested in COM/.NET Interoperability.

OLEVIEW screenshot showing Component Categories

If one clicks on the .NET category icons that one gets a long list of .NET classes. I want to focus on two blocks both from the .NET namespace, System.Collections and System.Text. In the screenshot on the right hand side one can see the two blocks given as fragments (I have rubbed out surrounding entries).

How Component Category details are registered

Components belong to a category if they have extra keys in the registry. Under the CLSID entry, there needs to be an 'Implemented Categories' key, under which there needs to be a key for each category the class belongs to. The details of categories are registered separately and given a category ID (CATID) which is a GUID just like CLSID. Perhaps a registry export can clarify, the following is the registry details for a System.Collections.SortedList

Windows Registry Editor Version 5.00

[HKEY_CLASSES_ROOT\CLSID\{026CC6D7-34B2-33D5-B551-CA31EB6CE345}]
@="System.Collections.SortedList"

[HKEY_CLASSES_ROOT\CLSID\{026CC6D7-34B2-33D5-B551-CA31EB6CE345}\Implemented Categories]

[HKEY_CLASSES_ROOT\CLSID\{026CC6D7-34B2-33D5-B551-CA31EB6CE345}\Implemented Categories\{62C8FE65-4EBB-45E7-B440-6E39B2CDBF29}]

[HKEY_CLASSES_ROOT\CLSID\{026CC6D7-34B2-33D5-B551-CA31EB6CE345}\InprocServer32]
@="C:\\Windows\\System32\\mscoree.dll"
"Assembly"="mscorlib, Version=2.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089"
"Class"="System.Collections.SortedList"
"ThreadingModel"="Both"

[HKEY_CLASSES_ROOT\CLSID\{026CC6D7-34B2-33D5-B551-CA31EB6CE345}\ProgId]
@="System.Collections.SortedList"

As I said the details, in this case the friendly text name, is stored elsewhere under HKCR\Component Categories\ here, specifically, is the NET Category ID...

[HKEY_CLASSES_ROOT\Component Categories\{62C8FE65-4EBB-45e7-B440-6E39B2CDBF29}]
"0"=".NET Category"
"409"=".NET Category"

Talk-through of code to find .NET category COM classes, filtered to be VBA creatable and reflectable

I want to investigate what .NET classes exposed as COM classes can be created in VBA so I can use them instead of say Scriping.Dictionary. I also want to interrogate them for their methods, so I want them to be reflectable. I wrote some code but the resultant list was very long so I narrowed it down further, many of the NET classes exposed as COM classes are in fact Exception classes or Attribute classes and I could not imagine VBA code creating one of these so I filtered them. Then the list was still too long (at least for a blog) so I narrowed it down to the System.Collections.* namespace and the System.Text.* namespace. You can amend the code and lift those restrictions to see a bigger list BUT AT YOUR OWN RISK.

The code is peppered with comments so I'll try not to replicate those. Instead I will summarise the logic, it will sweep the registry looking for CLSIDs, i.e. registered COM classes, then for each CLSID it looks for the .NET Category CatID. If a .NET Category class is found the code then attempts to instantiate the class with VBA.CreateObject, if that fails the class is pretty much useless to a VBA developer (though I suppose we could be passed one out of a .NET assembly). Further because the Intellisense is not working for these classes (something I will return to) I want to be able to interrogate the class using .NET reflection, this means the GetType method must be implemented. If all those filters are passed then it gets added to a list. The collated list is pasted to a column on a worksheet (Sheet1, warning will overwrite!). My (tabulated) list looks as follows

.NET classes exposed as COM classes that are creatable and reflectable

System.Collections.ArrayList System.Collections.Queue System.Text.StringBuilder
System.Collections.CaseInsensitiveComparer System.Collections.SortedList System.Text.UnicodeEncoding
System.Collections.CaseInsensitiveHashCodeProvider System.Collections.Stack System.Text.UTF7Encoding
System.Collections.Hashtable System.Text.ASCIIEncoding System.Text.UTF8Encoding

The program listing

This code will needs a Tools->Reference to the .net run time mscorlib.dll.

Option Explicit
Option Private Module

'https://msdn.microsoft.com/en-us/library/aa390387(v=vs.85).aspx
Private Const HKCR = &H80000000

Private Const msDotNetCategoryID As String = "{62C8FE65-4EBB-45E7-B440-6E39B2CDBF29}"

Private Sub FindDotNotComEnabledObjects()

    Dim oWMIReg As Object
    Set oWMIReg = GetStdRegProv

    Debug.Assert TypeName(oWMIReg) = "SWbemObjectEx"

    Dim sKeyPath As String
    sKeyPath = "CLSID"

    '*
    '* Get a list of all keys under CLSID
    '*
    Dim vClsIds As Variant
    Call oWMIReg.EnumKey(HKCR, sKeyPath, vClsIds)

    Dim objSortedList As Object ' mscorlib.SortedList
    Set objSortedList = CreateObject("System.Collections.SortedList") 'New mscorlib.SortedList

    Dim vClsIdLoop As Variant
    For Each vClsIdLoop In vClsIds
        Dim sProgId As String
        
        If ProbeForImplementedCategory(vClsIdLoop, msDotNetCategoryID, sProgId) Then
            '*
            '* select in progids belonging to .NET collections and text processing
            '* i.e. namespaces that are prefixed System.Collection.* or System.Text.*
            '*
            If Left(sProgId, 11) = "System.Text" Or Left(sProgId, 18) = "System.Collections" Then
            
                '*
                '* select out Exceptions and Attributes
                '*
                If Right(sProgId, 9) <> "Exception" And Right(sProgId, 9) <> "Attribute" Then
                
                    '*
                    '* only interested in those creatable from VBA and have implemented System.Object.GetType
                    '*
                    Dim bHasGetType As Boolean
                    If CreatableProgId(sProgId, bHasGetType) Then
                    
                        objSortedList.Add sProgId, 0
                    End If
                End If
            End If

        End If
    Next vClsIdLoop

    '*
    '* paste the filtered results to the worksheet
    '*
    Dim oKeys As Object
    Set oKeys = CreateObject("System.Collections.ArrayList")
    oKeys.AddRange objSortedList.GetKeyList()
    Sheet1.Cells(1, 1).Resize(objSortedList.Count, 1).Value2 = Application.Transpose(oKeys.ToArray)

    'Stop
End Sub

Private Function GetStdRegProv() As Object
    '*
    '* Placing separately faciliates unit tests
    '*
    Static oWMIReg As Object
    If oWMIReg Is Nothing Then
        Set oWMIReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\.rootdefault:StdRegProv")
    End If
    Set GetStdRegProv = oWMIReg
End Function

Private Function CreatableProgId(ByVal sProgId As String, ByRef pbHasGetType As Boolean) As Boolean
    '*
    '* Two Error Handlers in this procedure (because I was interested in the different error numbers)
    '* nevertheless there are two hoops to jump through
    '* (1) create the object (2) get the Type
    '*
    On Error GoTo CreateObjectErrHand

    Dim obj As Object
    Set obj = VBA.CreateObject(sProgId)
    CreatableProgId = True

    On Error GoTo GetTypeErrHand
    '*Tools->References->mscorlib
    Dim objType As mscorlib.Type
    Set objType = obj.GetType
    pbHasGetType = True

SingleExit:
    Exit Function
CreateObjectErrHand:
    Debug.Assert Err.Number = 424 Or Err.Number = 429 Or Err.Number = &H80070002 Or Err.Number = &H80131040 Or Err.Number = &H80131522
    GoTo SingleExit

GetTypeErrHand:

    Debug.Assert Err.Number = 438 Or Err.Number = 424
    GoTo SingleExit

End Function

Private Sub UnitTestProbeForImplementedCategory()
    Dim sProgId As String
    Debug.Print ProbeForImplementedCategory("{026CC6D7-34B2-33D5-B551-CA31EB6CE345}", msDotNetCategoryID, sProgId)
End Sub

Private Function ProbeForImplementedCategory(ByVal sClsId As String, ByVal sCatId As String, ByRef psProgId As String) As Boolean
    
    '*
    '* For a given CLSID we probe subkeys looking for Implemented Categories
    '*

    Dim sPath As String
    sPath = "CLSID" & sClsId & "Implemented Categories"

    Dim oWMIReg As Object
    Set oWMIReg = GetStdRegProv

    '*
    '* get list of subkeys (totalling typically 0,1 or 2), they will be CatIDs
    '*
    Dim vCatIds As Variant
    Call oWMIReg.EnumKey(HKCR, sPath, vCatIds)

    If Not IsNull(vCatIds) Then
        'Stop
        Dim vCatIdLoop As Variant
        For Each vCatIdLoop In vCatIds
            DoEvents
            If StrComp(vCatIdLoop, sCatId, vbTextCompare) = 0 Then

                psProgId = GetRegString("CLSID" & sClsId & "ProgId", "")

                ProbeForImplementedCategory = True
                GoTo SingleExit
            End If
        Next vCatIdLoop
    End If
SingleExit:

End Function

'**********************************************************************************
'* Syntactic sugar to compact code
'**********************************************************************************
Private Function GetRegString(ByVal sPath As String, sValue As String) As String
    Dim sRet As String

    GetStdRegProv.GetStringValue HKCR, sPath, sValue, sRet
    GetRegString = sRet
End Function

VBA - .NET - Writing a System.Collections.SortedList to an Excel Worksheet

I have been playing around with some .NET objects that are creatable and usable from VBA. I was wondering if I could stop using Scripting.Dictionary and start using the .net collections classes. I use Scripting.Dictionary for a great many use cases because it exports variants arrays which are easily passed around and pastable onto a worksheet. What would code to write the contents of a System.Collections.SortedList look like?

On a documentation note, we have to wrestle with the lack of Intellisense (even if you do early bind to mscorlib!), I will return to that topic soon but for the meantime see here for a list of methods and properties of SortedList. I investigated them for a while and here are my findings.

We can use SortedList.GetKeyList() directly ourselves or we can pass the return result to ArrayList.AddRange(). This gives rise to three different approaches and code is given below for each. Enjoy!

Option Explicit

Function CreateSortedList() As Object
    '* common code to all attempts
    Dim objSortedList As Object ' mscorlib.SortedList
    Set objSortedList = CreateObject("System.Collections.SortedList") 'New mscorlib.SortedList
    objSortedList.Add "Red", 0
    objSortedList.Add "Green", 0
    objSortedList.Add "Blue", 0
    Set CreateSortedList = objSortedList

End Function

Sub WriteASortedListToASheet_UseArrayListToHelp()

    '*
    '* This approach has fewer lines of code but I suspect not the fastest
    '*

    Dim objSortedList As Object ' mscorlib.SortedList
    Set objSortedList = CreateSortedList
    
    '*
    '* calling SortedList.GetKeyList() and passing results to ArrayList
    '*
    
    Dim oKeys As Object
    Set oKeys = CreateObject("System.Collections.ArrayList")
    oKeys.AddRange objSortedList.GetKeyList()

    Sheet1.Cells(1, 1) = "ArrayList.ToArray()"
    Sheet1.Cells(2, 1).Resize(objSortedList.Count, 1).Value2 = Application.Transpose(oKeys.ToArray)

End Sub

Sub WriteASortedListToASheet_ReverseArrayManuallyWithGetKey()

    '*
    '* This approach builds a pastable array manually by looping through for each element
    '*

    Dim objSortedList As Object ' mscorlib.SortedList
    Set objSortedList = CreateSortedList
    
    ReDim vKeyList(1 To objSortedList.Count, 1 To 1)
    Dim lKeyLoop As Long
    For lKeyLoop = 0 To objSortedList.Count - 1
        vKeyList(lKeyLoop + 1, 1) = objSortedList.GetKey(lKeyLoop)
    
    Next lKeyLoop
    Sheet1.Cells(1, 3) = "GetKey()"
    Sheet1.Cells(2, 3).Resize(objSortedList.Count, 1).Value2 = vKeyList

End Sub

Sub WriteASortedListToASheet_ReverseArrayManuallyWithGetKeyList()

    '*
    '* This approach builds a paste-able array manually by looping through for each element of a KeyList
    '*

    Dim objSortedList As Object ' mscorlib.SortedList
    Set objSortedList = CreateSortedList
        
    Dim objList As Object 'IList
    Set objList = objSortedList.GetKeyList()

    ReDim vKeyList(1 To objSortedList.Count, 1 To 1)
    Dim lKeyLoop As Long
    For lKeyLoop = 0 To objSortedList.Count - 1
        vKeyList(lKeyLoop + 1, 1) = objList.Item(lKeyLoop)
    
    Next lKeyLoop
    
    Sheet1.Cells(1, 5) = "GetKeyList()"
    Sheet1.Cells(2, 5).Resize(objSortedList.Count, 1).Value2 = vKeyList

End Sub

Thursday, 13 September 2018

VBA - .NET - Implement IComparable on your VBA classes to use .NET sorter

It is a common question to ask what is the best way to sort in VBA. Best can mean different things to different people. I do not wish to get into religious wars about sort algorithms, I simply give here a way of using a .NET sorter found in the System.Collections.ArrayList class. It requires implementing a standard .NET interface IComparable which is accessed by adding a Tools Reference to mscorlib.dll.

The use case given is a trivial one, we have Employees who have a unique identifier of an EmployeeId by which we will sort them.

Employee Class

First, the Employee class. After adding the Tools Reference to mscorlib.dll add the line Implements IComparable, this will require the implementation of only one method IComparable_CompareTo which must return -1,0 or 1 indicating smaller than, equal to or larger than.

We will sort employees by EmployeeID which will be a 32-bit integer so the implementation of IComparable_CompareTo below is easy. The logic can be very easily expanded to compare multiple variables, so long as the method returns -1,0 or 1.

The objects are held by System.Collections.ArrayList on a late bound basis (i.e. IDispatch) they are also passed in on a late bound basis so the obj parameter needs to be cast to Employee so it can be called for comparison.

Option Explicit

'*Tools->References->mscorlib.dll

Implements IComparable

Public EmployeeID As Long

Private Function IComparable_CompareTo(ByVal obj As Variant) As Long

    '* obj is late bound so we need to cast to get to a callable interface
    Dim oEmployee As Employee
    Set oEmployee = obj
    
    IComparable_CompareTo = (Me.EmployeeID - oEmployee.EmployeeID)

End Function

Test standard module

In a standard module (called anything) paste the following code. We create an instance of mscorlib.ArrayList but despite being early bound there was no Intellisense so we are a little in the dark.

Option Explicit

Function CreateNewEmployee(ByVal lEmployeeId As Long) As Employee
    Set CreateNewEmployee = New Employee
    CreateNewEmployee.EmployeeID = lEmployeeId
End Function

Sub Test()

    Dim oArrayList As mscorlib.ArrayList
    Set oArrayList = New mscorlib.ArrayList

    '* No Intellisense but for list of potential methods try
    '* https://docs.microsoft.com/en-us/dotnet/api/system.collections.arraylist.add?view=netframework-4.7.2
    oArrayList.Add CreateNewEmployee(1114)
    oArrayList.Add CreateNewEmployee(157)
    oArrayList.Add CreateNewEmployee(623)
        
    oArrayList.Sort

    Debug.Print oArrayList.Item(0).EmployeeID
    Debug.Print oArrayList.Item(1).EmployeeID
    Debug.Print oArrayList.Item(2).EmployeeID

    '* the above prints the following, demonstrating they have been sorted
    '   157
    '   623
    '   1114
End Sub

The code requires little further explanation and should be easy to follow. Simply run Test to see the results. For fun, you can set a break-point in the Employee class to watch the execution dive in and out between the .NET platform and your VBA and witness true VBA / .NET inter-operability.

Friday, 7 September 2018

VBA - XML - OLEDB - US Treasuries Web Service

So the code below will call the web service of the United States Treasury department that publishes Yield Curve data (bond interest rates). I wanted the data so I wrote this program and I might as well share. The code below shows Xml being parsed using the standard Xml libraries available to the VBA developer. The Xml is parsed into a two dimensional array which is pasted onto a sheet called Batch.

Excel's OLEDB Provider supports outer joins and INSERT INTO SELECT

So most of the code is concerned with the Xml parsing and writing the data to Batch sheet. However, I need some logic to update the Master sheet. The Master sheet is meant to contain all previous results not just the batch of data acquired. The Master sheet must not have duplicates. Appending records to the Master is a task ideally suited for Microsoft Access and other database technologies. In the past I might have written VBA to loop through the rows individually to establish if Master doesn't yet have that record before appending it by pasting to the bottom.

But this is a good case to use Excel's OLEDB Provider. In ANSI SQL there is the INSERT INTO SELECT sql statement which selects from one table and inserts into another. But I want no duplicates so I use an outer join and test for nulls. I am pleased to say Excel's OLEDB Provider can handle this (whereas the deprecated JET driver might not have) and that this is achieved in so few lines of code, here it is ...

Sub UpdaterMaster()

    Dim oConn As ADODB.Connection
    Set oConn = New ADODB.Connection
    
    Debug.Assert UBound(Split(ThisWorkbook.Name, ".")) > 0  '* Workbook needs to be saved
    
    oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
           "Data Source=" & ThisWorkbook.FullName & ";" & _
           "Extended Properties='Excel 12.0 Macro'"

    oConn.Execute "INSERT INTO [Master$] Select B.* from [Batch$] AS B LEFT join [Master$] as M on B.Date=M.Date where IsNull(M.Date )"
    
    SortMaster
End Sub

Actually, it is one magic line, highlighted in blue.

In the future, for tabular data processing on worksheets I will always look first at Excel's OLEDB Provider to see if it is capable. So much code saved!

Caveat

The Master sheet cannot be empty. So to get going you need to copy over manually the first batch. That could be automated.

Full Listing

The full listing is shown here

Option Explicit
    
Private mvData()
Private mlRowCount As Long

Public Enum ycfYieldCurveFeed
    ycfId = 1
    ycfNEW_DATE
    ycfBC_1MONTH
    ycfBC_3MONTH
    ycfBC_6MONTH
    ycfBC_1YEAR
    ycfBC_2YEAR
    ycfBC_3YEAR
    ycfBC_5YEAR
    ycfBC_7YEAR
    ycfBC_10YEAR
    ycfBC_20YEAR
    ycfBC_30YEAR
    ycfBC_30YEARDISPLAY
    ycfMin = ycfId
    ycfMax = ycfBC_30YEARDISPLAY
End Enum

Function BatchSheet() As Excel.Worksheet
    Set BatchSheet = ThisWorkbook.Worksheets("Batch")
End Function

Function MasterSheet() As Excel.Worksheet
    Set MasterSheet = ThisWorkbook.Worksheets("Master")
End Function

Sub GetTreasuryData()

    Dim shBatch As Excel.Worksheet
    Set shBatch = BatchSheet

    Dim oXHR As MSXML2.XMLHTTP60
    Set oXHR = New MSXML2.XMLHTTP60
    
    mlRowCount = 0
    ReDim mvData(ycfMin To ycfMax, 0 To mlRowCount)
    AddColumnHeadings
    
    Dim lYearLoop As Long
    For lYearLoop = 2018 To 2018
    
        Dim dtStart As Date
        dtStart = DateSerial(lYearLoop, 1, 1)
        
        Dim dtEnd As Date
        dtEnd = DateSerial(lYearLoop, 12, 31)
        
        shBatch.Cells.ClearContents
        
        Dim dtLoop As Date
        For dtLoop = dtStart To dtEnd
            
            DoEvents
            Debug.Print VBA.FormatDateTime(dtLoop, vbLongDate)
            Dim lWeekday As Long
            lWeekday = Weekday(dtLoop, vbSunday)
            
            If Not (lWeekday = 1 Or lWeekday = 7) Then
        
                Dim sURL As String
                sURL = USTreasuryUrl(dtLoop)
            
                oXHR.Open "GET", sURL, False
                oXHR.send
                
                Dim xmlPage As MSXML2.DOMDocument60
                Set xmlPage = New MSXML2.DOMDocument60
                xmlPage.LoadXML oXHR.responseText
                
                xmlPage.setProperty "SelectionNamespaces", "xmlns:ust='http://www.w3.org/2005/Atom' xmlns:m='http://schemas.microsoft.com/ado/2007/08/dataservices/metadata' xmlns:d='http://schemas.microsoft.com/ado/2007/08/dataservices'"
                
                Dim xmlEntries As MSXML2.IXMLDOMNodeList
                Set xmlEntries = xmlPage.SelectNodes("ust:feed/ust:entry/ust:content/m:properties")
                
                'Dim dtLastSnapDate As Date
                
                Dim xmlEntryLoop As MSXML2.IXMLDOMElement
                For Each xmlEntryLoop In xmlEntries
                
                    mlRowCount = mlRowCount + 1
                    ReDim Preserve mvData(ycfMin To ycfMax, 0 To mlRowCount)
                    
                    Dim xmlProps As MSXML2.IXMLDOMNodeList
                    Set xmlProps = xmlEntryLoop.SelectNodes("*")
                    
                    Dim xmlProp As MSXML2.IXMLDOMElement
                    For Each xmlProp In xmlProps
                        
                        Dim sType As String
                        sType = xmlProp.getAttribute("m:type")
                        
                        If xmlProp.getAttribute("m:null") = True Then
                            '*skip the null
                        Else
                            If StrComp(sType, "Edm.Int32", vbTextCompare) = 0 Then
                                mvData(ycfId, mlRowCount) = CLng(xmlProp.nodeTypedValue)
                                
                            ElseIf StrComp(sType, "Edm.DateTime", vbTextCompare) = 0 Then
                                Dim vSplitDate As Variant
                                vSplitDate = VBA.Split(xmlProp.nodeTypedValue, "T")
                                Dim vSplit2 As Variant
                                vSplit2 = Split(vSplitDate(0), "-")
                                Dim dtSnapDate As Date
                                dtSnapDate = DateSerial(vSplit2(0), vSplit2(1), vSplit2(2))
                                
                                'Debug.Assert dtSnapDate > dtLastSnapDate
                                'dtLastSnapDate = dtSnapDate
                                mvData(ycfNEW_DATE, mlRowCount) = CLng(dtSnapDate)

                            ElseIf StrComp(sType, "Edm.Double", vbTextCompare) = 0 Then
                                mvData(LookupColumnOrdinal(xmlProp.BaseName), mlRowCount) = CDbl(xmlProp.nodeTypedValue)
                            Else
                                Stop '*unrecognized
                            End If
                        
                        End If
                    
                    Next
                
                Next xmlEntryLoop
            
            End If
        Next
        
    Next lYearLoop
    Dim rng As Excel.Range
    Set rng = shBatch.Range(shBatch.Cells(1, 1), shBatch.Cells(mlRowCount + 1, ycfMax))
    rng.Value = Application.WorksheetFunction.Transpose(mvData)

    UpdaterMaster
End Sub



Sub UpdaterMaster()

    Dim oConn As ADODB.Connection
    Set oConn = New ADODB.Connection
    
    Debug.Assert UBound(Split(ThisWorkbook.Name, ".")) > 0  '* Workbook needs to be saved
    
    oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
           "Data Source=" & ThisWorkbook.FullName & ";" & _
           "Extended Properties='Excel 12.0 Macro'"

    oConn.Execute "INSERT INTO [Master$] Select B.* from [Batch$] AS B LEFT join [Master$] as M on B.Date=M.Date where IsNull(M.Date )"
    
    SortMaster
End Sub

Sub SortMaster()

    Dim wsMasters As Excel.Worksheet
    Set wsMasters = MasterSheet

    Dim rngTable As Excel.Range
    Set rngTable = wsMasters.Cells(1, 1).CurrentRegion
    
    Dim rngKey As Excel.Range
    Set rngKey = rngTable.Columns(2).Resize(rngTable.Rows.Count - 1).Offset(1)
    
    
    wsMasters.Sort.SortFields.Clear
    wsMasters.Sort.SortFields.Add Key:=rngKey _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wsMasters.Sort
        .SetRange rngTable
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

Private Function USTreasuryUrl(ByVal dtSnapDate As Date) As String

    Dim lDay As Long
    lDay = Day(dtSnapDate)
    
    Dim lMonth As Long
    lMonth = Month(dtSnapDate)
     
    Dim lYear As Long
    lYear = Year(dtSnapDate)

    Dim sTemplate As String
    sTemplate = "http://data.treasury.gov/feed.svc/DailyTreasuryYieldCurveRateData?$filter=day(NEW_DATE) eq $DAY$ and month(NEW_DATE) eq $MONTH$ and year(NEW_DATE) eq $YEAR$"
    
    USTreasuryUrl = Replace(Replace(Replace(Replace(sTemplate, "$DAY$", CStr(lDay)), "$MONTH$", CStr(lMonth)), "$YEAR$", CStr(lYear)), " ", " ")
    

End Function

Private Function LookupColumnOrdinal(ByVal sBaseName As String) As ycfYieldCurveFeed
    Static dicLookup As Scripting.Dictionary
    If dicLookup Is Nothing Then
        Set dicLookup = New Scripting.Dictionary
        dicLookup.CompareMode = TextCompare
        
        dicLookup.Add "Id", ycfId
        dicLookup.Add "NEW_DATE", ycfNEW_DATE
        dicLookup.Add "BC_1MONTH", ycfBC_1MONTH
        dicLookup.Add "BC_3MONTH", ycfBC_3MONTH
        dicLookup.Add "BC_6MONTH", ycfBC_6MONTH
        dicLookup.Add "BC_1YEAR", ycfBC_1YEAR
        dicLookup.Add "BC_2YEAR", ycfBC_2YEAR
        dicLookup.Add "BC_3YEAR", ycfBC_3YEAR
        dicLookup.Add "BC_5YEAR", ycfBC_5YEAR
        dicLookup.Add "BC_7YEAR", ycfBC_7YEAR
        dicLookup.Add "BC_10YEAR", ycfBC_10YEAR
        dicLookup.Add "BC_20YEAR", ycfBC_20YEAR
        dicLookup.Add "BC_30YEAR", ycfBC_30YEAR
        dicLookup.Add "BC_30YEARDISPLAY", ycfBC_30YEARDISPLAY
    End If

    Debug.Assert dicLookup.Exists(sBaseName)
    LookupColumnOrdinal = dicLookup.Item(sBaseName)
End Function

Private Sub AddColumnHeadings()
    mvData(ycfId, 0) = "Id"
    mvData(ycfNEW_DATE, 0) = "Date"
    mvData(ycfBC_1MONTH, 0) = "1M"
    mvData(ycfBC_3MONTH, 0) = "3M"
    mvData(ycfBC_6MONTH, 0) = "6M"
    mvData(ycfBC_1YEAR, 0) = "1Y"
    mvData(ycfBC_2YEAR, 0) = "2Y"
    mvData(ycfBC_3YEAR, 0) = "3Y"
    mvData(ycfBC_5YEAR, 0) = "5Y"
    mvData(ycfBC_7YEAR, 0) = "7Y"
    mvData(ycfBC_10YEAR, 0) = "10Y"
    mvData(ycfBC_20YEAR, 0) = "20Y"
    mvData(ycfBC_30YEAR, 0) = "30Y"
    mvData(ycfBC_30YEARDISPLAY, 0) = "*"
End Sub

Thursday, 6 September 2018

VBA - Types - The Object Browser

I intend to post about Types and Type Libraries etc. and low-level COM interfaces that facilitate their discovery, just like reflection. Before I do I need to cover the basics of Types using the tools that a VBA developer has to hand. The first of these is the VBA IDE's Object Browser.

The two screenshots of the object browser above should be familiar and they show two separately libraries, the VBA library on the left and the Microsoft Scripting Runtime library on the right. I prefer to work with the Microsoft Scripting Runtime for the examples in this series of posts.

Showing Hidden Members

It is a little known feature of the VBA IDE Object Browser that it will reveal some hidden members. The following screenshot shows the menu option selected for the Scripting library and its hidden members revealed.

Some elements are more hidden than others

I will give a sneak preview of some of the Interface Definition Language (IDL) that is used to define the Scripting type library. Below there are two methods, one highlighted in blue and the other in red. The method in red HashVal was displayed after we selected Show Hidden Members' from the menu. However, the method in blue, _NewEnum, remains hidden, that is because it is marked with the restricted attribute.


    interface IDictionary : IDispatch {
        ...
        [id(0xfffffffc), restricted]
        HRESULT _NewEnum([out, retval] IUnknown** ppunk);
        [id(0x0000000a), propget, hidden]
        HRESULT HashVal(
                        [in] VARIANT* Key, 
                        [out, retval] VARIANT* HashVal);
    };

If you are wondering what _NewEnum does then I can tell you it is what drives VBA's For Each statement. So you can see that sometimes it is necessary to restrict some methods from VBA developers. Here is some sample code that relies on the restricted _NewEnum method.

Option Explicit

Sub Test()

    Dim dic As Scripting.Dictionary
    Set dic = New Scripting.Dictionary
    
    dic.Add "Red", "FF0000"
    dic.Add "Green", "00FF00"
    dic.Add "Blue", "0000FF"

    Dim v As Variant
    For Each v In dic
        Debug.Print v, dic(v)
    Next v

End Sub

What's Next?

So I do not intend to show the Object Browser again as I have demonstrated how it does not tell the full story. Instead I will work with and only show OLEVIEW.exe which I will introduce in the next post.

VBA - Inheritance ... or as close as you will get ... better in fact.

So far, this blog has not opined on VBA inheritance or more accurately the simulation of inheritance; time to rectify that here. We could use composition along with a standard naming convention to mimic inheritance as found in languages such as C++ and C#. But we can use the default member trick to make the syntax even tighter.

C# and C++ Inheritance and the Fragile Base Class Problem

Before people complain that follows is not like the true inheritance found in C# and C++ I would say that what follows has some superior benefits. C++ and C# inheritance breaks encapsulation because derived classes can gain access to the base class's members. Also, once derived classes are written it becomes difficult to re-engineer the base class without breaking the derived classes, this is known as the fragile base class problem. Indeed, languages such as C# have to invent keywords such sealed to prevent derived classes inspecting a base class's private variables.

VBA can use Composition and the Default Member Trick to simulate Inheritance

What follows is VBA composition dressed up as inheritance by using the default member trick to tighten the syntax. So it has all the benefits of composition over inheritance

Code Listings

In the following listings, to effect Class1 and Class2 as intended it is not sufficient to cut and paste into VBA environment, it is also required to export to disk, load into editor, edit the file, save and then re-import; details are given in the code.

Class1 Listing

Option Explicit

Private moBase As Class2

'* To do the default member trick
'* 1) Export this module to disk;
'* 2) load into text editor;
'* 3) uncomment line with text Attribute Item.VB_UserMemId = 0 ;
'* 4) save the file back to disk
'* 5) remove or rename original file from VBA project to make room
'* 6) Re-import saved file


Private Sub Class_Initialize()
    Set moBase = New Class2
End Sub

Public Function Base() As Class2
    'Attribute Item.VB_UserMemId = 0
    Set Base = moBase
End Function

Public Function Foo() As String
    Foo = "Class1.Foo:" & 23
End Function

Public Function Common() As String
    Common = "Class1.Common"
End Function

Class2 Listing

Option Explicit

Private moBase As Class3

'* To do the default member trick
'* 1) Export this module to disk;
'* 2) load into text editor;
'* 3) uncomment line with text Attribute Item.VB_UserMemId = 0 ;
'* 4) save the file back to disk
'* 5) remove or rename original file from VBA project to make room
'* 6) Re-import saved file

Private Sub Class_Initialize()
    Set moBase = New Class3
End Sub

Public Function Base() As Class3
    'Attribute Item.VB_UserMemId = 0
    Set Base = moBase
End Function


Public Function Bar() As String
    Bar = "Class2.Bar:" & 42
End Function

Public Function Common() As String
    Common = "Class2.Common"
End Function

Class3 Listing

Option Explicit

Public Function Baz() As String
    Baz = "Class3.Baz:" & -5
End Function

Public Function Common() As String
    Common = "Class3.Common"
End Function

Test Module

So hopefully you have imported the above classes and edited Class1 and Class2 necessarily to effect the default member trick. So now one can see how this works using the test code below. One can access a class's base class simply by adding .Base qualifier but we can tighten the syntax to just a pair of round brackets using the default member trick.

Option Explicit

Sub Test()
    Dim oClass1 As Class1
    Set oClass1 = New Class1

    '* without using default member trick
    '* access common method method
    Debug.Print oClass1.Common              '* prints Class1.Common
    Debug.Print oClass1.Base.Common         '* prints Class2.Common
    Debug.Print oClass1.Base.Base.Common    '* prints Class3.Common

    '* using default member trick (Attribute Item.VB_UserMemId = 0)
    '* access common method method
    Debug.Print oClass1.Common      '* prints Class1.Common
    Debug.Print oClass1().Common    '* prints Class2.Common
    Debug.Print oClass1()().Common  '* prints Class3.Common

    '* access a base class's unique method (using default member trick)
    Debug.Print oClass1.Foo      '* prints Class1.Foo:23
    Debug.Print oClass1().Bar    '* prints Class2.Bar:42
    Debug.Print oClass1()().Baz  '* prints Class3.Baz:-5

End Sub

No need for Virtual or Overides keywords

Of note is the test code above that calls the Common method. So you see how without the virtual and overrides keywords found in other languages we can in fact easily determine which implementation of Common in the 'inheritance' chain to call by changing the number of bracket pairs.

Final Thoughts

I felt the need to post this because whilst investigating COM Type libraries, I thought I had found a secret way to aggregate a VBA class. (Aggregation is COM's reuse feature.) That turned our to be a mirage (details to follow in a separate post, maybe). I wanted somewhere on this blog to demonstrate how VBA developers can use something very conceptually close to inheritance in their designs.