C# Versions of COM interfaces

This article has been migrated to our sister C# blog

"Interface marked as restricted" compile error prevents QueryInterface

In Com the method IUnknown.QueryInterface allows a client to hop between interfaces, this is callable via C++ but not VBA.  VBA has a different mechanism, one uses Dim itfFoo as IKung to declare the interface and then a call to Set itfFoo = objBar, where objBar is a Com object that implements the interface IKung.

However, this is also dependent of being able to write the Dim statement as such.  Not all interfaces play ball, they have types which cannot be represented in VBA and so the compiler chokes.  Following is an example.  When this happens you need to turn to C++.

Option Explicit
Option Private Module

Private Sub Test()


'**********************************************************************************
'* The following works and demonstrates a successful QueryInterface
'**********************************************************************************

    Dim obj As Object 'This is VBA way of asking of declaring IDispatch
    Set obj = VBA.CreateObject("Scripting.Dictionary")


    Dim itfUnk As stdole.IUnknown   'The canonical COM interface
    Set itfUnk = obj   '--- this does a QueryInterface , it asks for IUnknown

'**********************************************************************************
'* The following fails with compile errors, try uncommenting to see
'**********************************************************************************

    '* Compile error:
    '*
    '* Function or interface marked as restricted, or the function uses an
    '* Automation type not supported in Visual Basic


    'Dim itfDisp As stdole.IDispatch
    'Set itfDisp = obj

'******************************************************************************
    
    '* Compile error: User-defined type not defined
    '* Needs a Tools->Reference but where is IParseDisplayName defined?
    '* shame vba cannot declare interfaces by IID like C++
    
    'Dim itfUnk As IParseDisplayName
    'Set itfUnk = obj

'******************************************************************************

End Sub

Ideone.com: Online C++ Editor

Following on from a post about JSFiddle I have chanced across an online C++ editor, http://ideone.com.

I have written a quick piece of code in C++14 which iterates through some strings and reads them into pairs. The code uses modern C++ (C++11/C++14) structures such as: only standard library strings, the auto keyword to simplify variable declarations, use of vector as the canonical container, using iterators begin() and end().

However, like JSFiddle questions over intellectual property rights have to be asked. Also, code needs input and whilst there is space for input one cannot upload files etc.

Use JSFiddle to share Javascript problems

So online compilation is improving, during my travels I have seen online Javascript editing environments, for example there is JSFiddle (screenshot below).  Here is a specific Angular.js example

One can see the page is divided into 4 quadrants, HTML, CSS, JAVASCRIPT and resulting output. One can play aropund and experiment and if you get stuck then you can use it as a link in a StackOverflow question and gets some help. A truly useful online collaboration tool. However, questions could be asked about the intellectual property rights so I would advise limiting to learning concepts.

Code to Kill Support Scam Web Page

"Critical Alert from Microsoft" virus is a support scam and it can be very frustrating, one can try to close the comment window and then get to the close button but the virus seems to have some fiendish Javascript that prevents keyboard action. The Task Manager isn't very good in these situations, I have often tried to kill the specific Chrome.exe process but frequently all of them are dropped.

Update

Best way to handle to kill chrome is to use from the command line

taskkill.exe /im Chrome.exe /f

It is the /f flag which forces a termination.

Windows API code to read button ids of a remote process

So this is some code which demonstrates how to allocate memory in a remote process, tell that process to fill the memory with some information and then copy that information back into our Excel.exe VBA script.

The process happens to be Oleview.exe and the information happens to be toolbars but it could be a wide variety of alternatives.

What is even more remarkable is that by the same mechanism it is possible to write to a process and inject code! I raised this on SO as a loophole but question got downvoted, so I deleted it. To me this is astounding and is a good counter-criticism to those critics of Excel VBA who says VBA is a vehicle for macros and malicious code. It seems the C++ guys have been able to run riot for years and years.

BUGFIX TODO: This code works only once for each new instance of Oleview.exe. This was sufficient for what I needed which was the button ids. Will revisit some day.

Option Explicit

Private Declare PtrSafe Function FindWindowExA Lib "user32.dll" ( _
  ByVal hwndParent As LongPtr, _
  ByVal hwndChildAfter As LongPtr, _
  ByVal lpszClass As String, _
  ByVal lpszWindow As String) As Long

Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As Long


Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hWnd As Long, ByVal wMsg As Long, _
        ByVal wParam As Long, lParam As Any) As Long

Private Declare Function GetWindowThreadProcessId Lib "user32" _
        (ByVal hWnd As Long, lpdwProcessId As Long) As Long



Private Declare PtrSafe Function OpenProcess Lib "kernel32" ( _
        ByVal dwDesiredAccess As Long, _
        ByVal bInheritHandle As Long, _
        ByVal dwProcessId As Long) As Long

Private Declare Function VirtualAllocEx Lib "kernel32" _
 (ByVal hProcess As Long, lpAddress As Any, dwSize As Any, _
ByVal flAllocationType As Long, ByVal flProtect As Long) As Long


'https://msdn.microsoft.com/en-us/library/windows/desktop/aa366894(v=vs.85).aspx
'BOOL WINAPI VirtualFreeEx(
'  _In_ HANDLE hProcess,
'  _In_ LPVOID lpAddress,
'  _In_ SIZE_T dwSize,
'  _In_ DWORD  dwFreeType
');

Private Declare Function VirtualFreeEx Lib "kernel32" _
 (ByVal hProcess As Long, ByVal lpAddress As Any, dwSize As Any, _
ByVal dwFreeType As Long) As Long


Private Declare Function ReadProcessMemory Lib "kernel32" _
    (ByVal hProcess As Long, lpBaseAddress As Long, lpBuffer As Any, _
    ByVal nSize As Long, lpNumberOfBytesWritten As Any) As Long


Private Const WM_COMMAND As Long = &H111
Private Const WM_USER = &H400
Private Const TB_BUTTONCOUNT = (WM_USER + 24)
Private Const TB_GETBUTTON = (WM_USER + 23)
Private Const TB_PRESSBUTTON = (WM_USER + 3)


Private Const PROCESS_VM_OPERATION = &H8&
Private Const PROCESS_VM_READ = &H10&
Private Const PROCESS_VM_WRITE = &H206

Private Const MEM_RESERVE = &H2000
Private Const MEM_COMMIT = &H1000
Private Const MEM_PHYSICAL = &H400000

Private Const MEM_DECOMMIT = &H4000
Private Const MEM_RELEASE = &H8000

Private Const PAGE_READWRITE = &H4

Private Type TBBUTTON
   iBitmap      As Long
   idCommand    As Long
   fsState      As Byte
   fsStyle      As Byte
   bReserved1   As Byte
   bReserved2   As Byte
   dwData       As Long
   iString      As Long
End Type

Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
        (ByVal dwFlags As Long, lpSource As Any, _
        ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _
        ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
  
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Const LANG_USER_DEFAULT = &H400&

Private Declare Function CloseHandle Lib "Kernel32.dll" _
   (ByVal Handle As Long) As Long

Private mlLastDllError As Long
Private msLastErrorStr As String
Private mbError As Boolean

'**********************************************************************************
'* Entry Point
'**********************************************************************************
Public Sub ReadOleViewButtonIds()

    Dim hWndToolbar As Long
    Dim lOleViewProcId As Long
    FindOleViewToolbarAndProcId hWndToolbar, lOleViewProcId

    Const PROCESS_ALL_ACCESS = &H1F0FFF
    Dim hWndProcessOleView As Long
    hWndProcessOleView = OpenProcess(PROCESS_ALL_ACCESS, 0, lOleViewProcId)
    If hWndProcessOleView = 0 Then
        Debug.Print Err.LastDllError
        Debug.Print GetLastErrorStr(Err.LastDllError)

        Stop
        End
    End If

    'https://social.msdn.microsoft.com/Forums/ie/en-US/cc1d7923-b1c7-478d-b ....
    'https://tinyurl.com/m8je6ph
    
    Dim lButtonCount    As Long
    lButtonCount = SendMessage(hWndToolbar, TB_BUTTONCOUNT, 0, 0)
    Debug.Assert lButtonCount <> 0
    
    Dim MyButton        As TBBUTTON

    'http://www.vbforums.com/showthread.php?80056-Trouble-using-VirtualAllocEx
    
    Dim pOleViewLocalMem As Long
    pOleViewLocalMem = VirtualAllocEx(hWndProcessOleView, Null, 4096, _
                                        MEM_RESERVE Or MEM_COMMIT, PAGE_READWRITE)

    If pOleViewLocalMem = 0 Then
        CaptureError
        Debug.Print ReportError("Error calling VirtualAllocEx ")

        Stop
        End
    End If
    
    Dim lButton As Long
    For lButton = 1 To lButtonCount

        Call SendMessage(hWndToolbar, TB_GETBUTTON, lButton, pOleViewLocalMem)

        Dim lBytesWritten As Long, ret As Long
        ret = ReadProcessMemory(hWndProcessOleView&, pOleViewLocalMem&, MyButton, _
                        20&, lBytesWritten)

        Debug.Assert ret <> 0
        Debug.Print lButton & " : " & MyButton.idCommand
        
    Next lButton
    
    VirtualFreeEx hWndProcessOleView, pOleViewLocalMem, 4096, MEM_RELEASE
    CloseHandle hWndToolbar
    CloseHandle hWndProcessOleView
    Stop


End Sub

'**********************************************************************************
'* Returns string error message
'**********************************************************************************
Function GetLastErrorStr(dwErrCode As Long) As String

  ' Let VB alloc the buffer. If FORMAT_MESSAGE_ALLOCATE_BUFFER
  ' was used, the lpBuffer param (sMsgBuf) would have to be a
  ' long pointer
  ' to the buffer & would then have to be freed when we're done.
  ' 256 chars is the maximun length for a resource string (+ 1
  ' for the null char)
  Static sMsgBuf As String * 257, dwLen As Long

  dwLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM _
                        Or FORMAT_MESSAGE_IGNORE_INSERTS _
                        Or FORMAT_MESSAGE_MAX_WIDTH_MASK, _
                        ByVal 0&, _
                        dwErrCode, LANG_USER_DEFAULT, _
                        ByVal sMsgBuf, 256&, 0&)

  If dwLen Then
      GetLastErrorStr = Trim$(Left$(sMsgBuf, dwLen))
  Else
     GetLastErrorStr = "Unknown error."
  End If

End Function


'**********************************************************************************
'* Function to get main window launched into explorer's desktop, i.e. the GUI
'**********************************************************************************
Private Function FindChildWindowOfDesktop(ByVal sWindowCaption As String) As Long
    Dim hDesktop As Long
    hDesktop = GetDesktopWindow
    Debug.Assert hDesktop <> 0

    Dim hWndMainWindow As Long
    hWndMainWindow = FindWindowExA(hDesktop, 0, vbNullString, sWindowCaption$)

    mbError = (hWndMainWindow = 0)
    If mbError Then NoErrMessage

    CloseHandle hDesktop                      '* no longer required
    FindChildWindowOfDesktop = hWndMainWindow '* return to caller, caller releases
End Function

'**********************************************************************************
'* Function to get procId from windows handle
'**********************************************************************************
Public Function FindProcIdFromHWnd(ByVal hWnd As Long) As Long

    Dim lOleViewThread As Long, lOleViewProcId As Long
    lOleViewThread = GetWindowThreadProcessId(hWnd, lOleViewProcId)

    mbError = (lOleViewThread = 0 Or lOleViewProcId = 0)
    If mbError Then CaptureError

    CloseHandle lOleViewThread               '* not required
    FindProcIdFromHWnd = lOleViewProcId      '* return to caller, caller releases

End Function

'**********************************************************************************
'* Packaging up earlier steps so we can tidy handles
'**********************************************************************************
Public Sub FindOleViewToolbarAndProcId(ByRef hWndToolbar As Long, _
                                                    ByRef lOleViewProcId As Long)

    Dim hWndMainWindow As Long
    hWndMainWindow = FindChildWindowOfDesktop("OLE/COM Object Viewer")
    If mbError Then
        Debug.Print ReportError("Could not get main window, " _
                   & "you need to run OLEVIEW.exe!!:")
        Stop
        End
    End If
    
    lOleViewProcId = FindProcIdFromHWnd(hWndMainWindow)
    If mbError Then
        Debug.Print ReportError("Could not get proc id from main window handle " _
                                                            & hWndMainWindow & ":")
        Stop
        End
    End If
    
    hWndToolbar = FindWindowExA(hWndMainWindow, 0, "ToolbarWindow32", "")
    If hWndToolbar = 0 Then
        Debug.Print Err.LastDllError
        Debug.Print GetLastErrorStr(Err.LastDllError)
        Stop
        End
    End If
    
    CloseHandle hWndMainWindow
    
End Sub

'**********************************************************************************
'* Some helpers for the error handling
'**********************************************************************************
Private Sub NoErrMessage()
    mlLastDllError = 0
    msLastErrorStr = vbNullString
End Sub

Private Sub CaptureError()
    mlLastDllError = Err.LastDllError
    msLastErrorStr = GetLastErrorStr(Err.LastDllError)
End Sub

Private Function ReportError(ByVal sPrefix As String)
    ReportError = sPrefix & " " & mlLastDllError & " " & msLastErrorStr
End Function

As I win StackOverflow 'Fanantic' Gold Medal here is a Miscellany of my SO Fails ...

So I use StackOverflow as a resource.  I ask questions because I think it is better than Google.  I also answer VBA questions not for the sake of kudos but if I can gain points then hopefully that means my questions get taken seriously.  It turns out that at midnight this evening I will win a gold medal "Fanatic" which is gained by turning up on SO 100 days in a row.  In this post I'm going to curb my enthusiasm by confessing to those of my questions I deleted because they were poorly received.  Here is a miscellany of my SO fails.

How to write C++ code to call into VBE7.dll to mimic VBA code?

I found that VBA's Left$ and Split etc. are all implemented in a file call VBE7.dll, I used Dependency Walker (Depends.exe) to establish this.  I asked SO if there was a header file that could call into this file.

Hans Passant replies

It is not documented. Not like you can't figure it out by trial and error, but you have little guarantee that your hard work is going to survive for long. And you have a nasty dependency that you can't distribute yourself. If the function is simple to reverse-engineer then it is also simple to re-implement it, and make it a lot better using the power of C++.

So Hans is saying essentially "Bad idea, don't be silly!"

What does “tag” prefix stand for [c++] in tagVARIANT and tagSAFEARRAY?

What does "tag" prefix stand for [c++] in tagVARIANT and tagSAFEARRAY? These are the COM structures but they are known as Variant and SafeArray. What is the "tag"? tagvariant| tagSAFEARRAY

Hans Passant replies

It comes from the C language, the language that inspired IDL syntax. Lots of google hits, this is one.

Yeah, so this is easy to Google for once you have the right search words "Structure Tags C", see top hit.

How to close VirtualAlloc loophole? Use different account credentials?

So I was writing some code to open an application and get information on its button structures and then send a message to click on the button. The tasks involved calling OpenProcess with access everything permission and then calling VirtualAlloc and then copying data into my process.

During my travels, I've seen examples of code injecting DLLs into another process. On reflection, this is a massive loophole. In fact, it is quite shocking.

How best to close VirtualAlloc loophole? Does configuring the exe to run under a different account (username/password) prevent (at the OpenProcess call)?

This got downvoted, it seems the SO is less bothered about this loophole. Here is an exchange of comments before I deleted question.

There is no "loophole". If it is a process you created, you have access to it. If it's someone else's process, you need "Administrator" privileges. – Ðаn 2 hours ago

@Dan: If I am software house and I write an application, and I am liable for screw-ups on customer's machine then it is very important to defend against code injection. – S Meaden 2 hours ago

It rather involved being on the other side of this airtight hatchway "Not every code injection bug is a security hole. Yes, a code injection bug is a serious one indeed. But it doesn't become a security hole until it actually allows someone to do something they normally wouldn't be able to." – Ðаn 1 hour ago

On any sane OS the programmer can't "defend" against an admin, and this is good IMHO. But I have the impression this is slowly changing... – alain 1 hour ago

Terminate, immediately, processes using WMI

There is something wrong with my computer, specifically the disk drive and virus checking.  When I take an update the virus scanner kicks in and my computer is rendered dead slow.  The slowness also occurs at other times.  I have learnt to manage this situation.  I have extra drives to spread the load with data files.  I also have installed a copy of Chrome on same extra drives and this helps.

Chrome is the best browser IMHO.  However, it does spawn multiple processes.  When the slowness kicks in I can see the disk queue via the Performance Monitor (accessed via Task Manager) shoot up to 50 or so.  When this happens killing processes via Task Manager is slow.  I think Task Manager sends a message to the process's message queue saying "please quit".   But I need to take back control of my computer far quicker.

It seems that WMI and the Win32_Process objects we can terminate immediately all the chrome.exes.  Here is some code.  Caution, use with care.

Option Explicit

'**********************************************************************************
'* Terminate, immediately
'**********************************************************************************
Function QuitChrome()

    Dim objWMIService As Object
    Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2")
    Dim colItems As Object
    Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process" & _
               " WHERE Name = 'chrome.exe'", , 48)
    Dim objItem As Object
    For Each objItem In colItems
        objItem.Terminate
    Next

End Function

Some feedback for some readers have pointed out a nice command line equivalent to kill Chrome.exe

taskkill /f /im chrome.exe

Thanks for that. This is an Excel coding blog but thanks anyway.

Use WMI to find PID from exe name

I'm starting to like WMI. I tend to be old school and will often google for a Windows API solution because I can call these in VBA. I know .NET programmers have a wonderful library but often clients place restrictions on one's VBA project.

For a little while I have been wresting with some Windows Api code which enumerates all of the processes, enumerates all the modules and then for the first module handle (conventionally the exe name) return the image (file) name. Except it's broken, something to do with mixing 32 and 64 bit processes. Arggghhh!

So why not for some WMI code? Here is some below, and is nice and short. I'm guess WMI has been developed as part of the Powershell initiative and so is probably the future. I think I will reach for WMI first hand in future.

Option Explicit

Sub TestGetProcessIds()
    Dim dicProcessIds As Scripting.Dictionary
    Set dicProcessIds = GetProcessIds("excel.exe")
    Debug.Print dicProcessIds.Keys()(0)
End Sub

'**********************************************************************************
'* GetProcessIds uses WMI's Win32_Process instead of
'* EnumProcesses, EnumProcessModules and GetModuleFileNameExA to match exe name
'**********************************************************************************
Function GetProcessIds(ByVal sImageName As String) As Scripting.Dictionary

    Dim dicProcessIds As Scripting.Dictionary
    Set dicProcessIds = New Scripting.Dictionary

    Dim objWMIService As Object
    Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2")
    Dim colItems As Object
    Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process" & _
               " WHERE Name = '" & sImageName & "'", , 48)
    Dim objItem As Object
    For Each objItem In colItems
        If Not dicProcessIds.Exists(objItem.ProcessId) Then 
            dicProcessIds.Add objItem.ProcessId, 0
        End If
    Next
    
    Set GetProcessIds = dicProcessIds

End Function

Using WMI this time to query disk drive information (plus Shell with ComSpec)

Another example of using WMI this time to query disk drive information, here we show the equivalent of running a command line vol.
This code also demonstrates shelling using the command spec see SO answer.

Option Explicit

'**********************************************************************************
'* Entry Point
'**********************************************************************************
Sub Main2()

    Debug.Assert Replace(VSNByCommandLine, "-", "") = VSNByWMI

End Sub

'**********************************************************************************
'* Volume Serial Number by WMI
'**********************************************************************************
Function VSNByWMI() As String
    Dim sSysDrive As String
    sSysDrive = Environ("SystemDrive")
    
    Dim sComputer As String
    sComputer = "."
    Dim objWMIService
    Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" _
            & sComputer & "\root\cimv2")
    
    Debug.Assert TypeName(objWMIService) = "SWbemServicesEx"
    

    Dim colDisks
    Set colDisks = objWMIService.ExecQuery _
        ("Select * from Win32_LogicalDisk where deviceid='" & sSysDrive & "'")
        
    Debug.Assert colDisks.Count = 1
    
    Dim sVolumeSerialNumber As String
    
    Dim objDisk
    For Each objDisk In colDisks
        sVolumeSerialNumber = objDisk.VolumeSerialNumber
    Next
    VSNByWMI = sVolumeSerialNumber
End Function

'**********************************************************************************
'* Volume Serial Number by Shelling to a command line andf running 'vol c:'
'**********************************************************************************
Function VSNByCommandLine() As String

    Dim sSysDrive As String
    sSysDrive = Environ("SystemDrive")    

    Dim sCmdSpec As String
    sCmdSpec = Environ("comspec")
    VBA.Shell sCmdSpec & " /C vol " & sSysDrive & " > C:\temp\vol.txt"
    
    Dim fso As Scripting.FileSystemObject
    Set fso = CreateObject("Scripting.filesystemobject")
    Debug.Assert fso.fileExists("c:\temp\vol.txt")
    
    Dim vVolPiped
    vVolPiped = Split(fso.OpenTextFile("c:\temp\vol.txt").readall)
    
    Dim sVol As String
    sVol = Replace(vVolPiped(UBound(vVolPiped)), vbNewLine, vbNullString)

    VSNByCommandLine = sVol
End Function

State loss proof storage

So just perusing the type libraries on my computer found using previous post.  I can see I made a C# assembly that allows the storing of VBA variables that would survive a state loss.  Then cross checking against SO I posted the code but then Florent B. posted a better version that needs no assembly.

It uses the default .Net application domain as a storage container. The code is a gem and worth repeating here

    Sub Usage()
        Dim dict As Object
        Set dict = GetPersistentDictionary()
    End Sub


    
    Public Function GetPersistentDictionary() As Object
        ' References:
        '  mscorlib.dll
        '  Common Language Runtime Execution Engine
        
        Const name = "weak-data"
        Static dict As Object
        
        If dict Is Nothing Then
          Dim host As New mscoree.CorRuntimeHost
          Dim domain As mscorlib.AppDomain
          host.Start
          host.GetDefaultDomain domain
          
          If IsObject(domain.GetData(name)) Then
            Set dict = domain.GetData(name)
          Else
            Set dict = CreateObject("Scripting.Dictionary")
            domain.SetData name, dict
          End If
        End If
        
        Set GetPersistentDictionary = dict
    End Function

Using WMI to query Registry for Type Libraries (like Tools->References)

All sorts of wonderful things are accessible via GetObject and then using a custom object activation schema, one day I will itemise all those that I have seen. In the meantime here is an example of querying the Registry using WMI to illustrate its usage.

The code loop through the typelib key in that part of the registry that handles COM. What we can output is something very similar to the Tools->References dialog box in VBA; and if we dump to sheet then we can easily search.

Option Explicit
Option Private Module

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


'*********************************************************************************
'* Late binding but one could use a Type library reference
'* Microsoft WMI Scripting V1.2 Library
'*********************************************************************************
Private oWMIReg As Object                          '* Late bound
'Private oWMIReg As WbemScripting.SWbemObjectEx     '* Early bound

Private lPass As Long
Private lRows As Long
Private vOutput

Private Enum coColumnOrdinals
    coGuid = 1
    coVersion
    coDescription
    coPIAName
    coPIACodeBase
    coWin32Binary
    coWin64Binary
    coFlags
    coHelpdir
    
    coMax = coHelpdir
End Enum

'**********************************************************************************
'* Entry Point
'**********************************************************************************
Sub Main()
    
    Dim sComputer As String
    sComputer = "."
    
    Set oWMIReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
            sComputer & "\root\default:StdRegProv")
    
    Debug.Assert TypeName(oWMIReg) = "SWbemObjectEx"
    
    Dim sKeyPath As String
    sKeyPath = "TypeLib"
    
    
    Dim vTypeLibraryGuids As Variant
    Call oWMIReg.EnumKey(HKCR, sKeyPath, vTypeLibraryGuids)
    
    
    For lPass = 0 To 1
        lRows = 0
    
        Dim vTypeLibraryGuidsLoop As Variant
        For Each vTypeLibraryGuidsLoop In vTypeLibraryGuids
            ReadTypeLibGuid sKeyPath, vTypeLibraryGuidsLoop
        Next vTypeLibraryGuidsLoop
        If lPass = 0 Then ReDim vOutput(1 To lRows, 1 To coMax)
    Next lPass
    
    
    Dim vColHeaders As Variant
    vColHeaders = Array("Guid", "Version", "Description", "PIAName", _
            "PIACodeBase", "Win32", "Win64", "Flags", "HelpDir")
    Sheet1.Cells.Clear
    
    Sheet1.Cells(1, 1).Resize(1, coMax).Value = _
        Application.Transpose(Application.Transpose(vColHeaders)) '* 1d to 2d
    Sheet1.Cells(1, 1).Offset(1).Resize(lRows, coMax).Value = vOutput




End Sub

'**********************************************************************************
'* Handles reading the type library details given a HKCR\typelib\{guid}
'**********************************************************************************
Sub ReadTypeLibGuid(ByVal sKeyPath As String, ByVal sTypeLibraryGuid As String)

    Dim sPath As String
    sPath = sKeyPath & "\" & sTypeLibraryGuid

    Dim vVersions As Variant
    Call oWMIReg.EnumKey(HKCR, sPath, vVersions)
    
    If Not IsNull(vVersions) Then
        Dim vVersionLoop As Variant
        For Each vVersionLoop In vVersions
            ReadTypeLibVersion sPath & "\" & vVersionLoop, sTypeLibraryGuid, _
                    vVersionLoop
        Next vVersionLoop
    End If

End Sub

'**********************************************************************************
'* Handles reading the type library version details
'* given a HKCR\typelib\{guid}\{version}
'**********************************************************************************
Function ReadTypeLibVersion(ByVal sPath2 As String, _
            ByVal vTypeLibraryGuidsLoop2 As String, ByVal vVersionLoop2 As String)

    
    lRows = lRows + 1
    If lPass = 1 Then
        vOutput(lRows, coGuid) = vTypeLibraryGuidsLoop2
        vOutput(lRows, coVersion) = vVersionLoop2
    End If
    
    ReadTypeLibVersionValues sPath2

    ReadTypeLibVersionKeys sPath2

End Function

'**********************************************************************************
'* Handles reading the type library version keys
'* given a HKCR\typelib\{guid}\{version}
'**********************************************************************************
Function ReadTypeLibVersionKeys(ByVal sPath2 As String)
    Dim vVersionDetailKeys As Variant
    Call oWMIReg.EnumKey(HKCR, sPath2, vVersionDetailKeys)
    
    If Not IsNull(vVersionDetailKeys) Then
        Dim vVersionDetailKeysLoop As Variant
        For Each vVersionDetailKeysLoop In vVersionDetailKeys
            
            Dim bIsWellKnownKey As Boolean
            bIsWellKnownKey = FoundInPipes("Flags|Helpdir", vVersionDetailKeysLoop)
                    
            If lPass = 1 Then
                If bIsWellKnownKey Then
                    Select Case LCase(vVersionDetailKeysLoop)
                    Case "flags"
                        Dim sFlags As String
                        sFlags = GetRegString(sPath2 & "\Flags", "")
                        vOutput(lRows, coFlags) = sFlags
                    Case "helpdir"
                        Dim sHelpdir As String
                        sHelpdir = GetRegString(sPath2 & "\Helpdir", "")
                        vOutput(lRows, coHelpdir) = sHelpdir
                    
                    Case Else
                        Stop
                    End Select
                End If
            End If
            
            If Not bIsWellKnownKey And IsNumeric(vVersionDetailKeysLoop) Then
            
                If lPass = 1 Then
                    If Len(vOutput(lRows, coDescription)) > 0 Then

                        FindWin3264 sPath2 & "\" & vVersionDetailKeysLoop
                    End If
                End If
            End If

        Next vVersionDetailKeysLoop
    End If

End Function

'**********************************************************************************
'* Handles reading the type library version values
'* given a HKCR\typelib\{guid}\{version}
'**********************************************************************************
Function ReadTypeLibVersionValues(ByVal sPath2 As String)
    Dim vVersionDetailValues As Variant
    Call oWMIReg.EnumValues(HKCR, sPath2, vVersionDetailValues)
    
    Dim sDesc As String
    
    If IsNull(vVersionDetailValues) Then
        If lPass = 1 Then
        
            sDesc = GetRegString(sPath2, "")
            vOutput(lRows, coDescription) = sDesc
        End If
    Else
        Dim vVersionDetailValueLoop As Variant
        For Each vVersionDetailValueLoop In vVersionDetailValues
            If lPass = 1 Then
                Select Case True
                Case Len(vVersionDetailValueLoop) = 0
                    sDesc = GetRegString(sPath2, "")

                    vOutput(lRows, coDescription) = sDesc
                Case vVersionDetailValueLoop = "PrimaryInteropAssemblyName"
                    
                    Dim sPIA As String
                    sPIA = GetRegString(sPath2, "PrimaryInteropAssemblyName")

                    vOutput(lRows, coPIAName) = sPIA
                Case vVersionDetailValueLoop = "PrimaryInteropAssemblyCodeBase"
                    Dim sPIACodeBase As String
                    sPIACodeBase = GetRegString(sPath2, _
                        "PrimaryInteropAssemblyCodeBase")

                    vOutput(lRows, coPIACodeBase) = sPIACodeBase
                Case Else
                    Stop
                End Select
                
            End If
        
        Next vVersionDetailValueLoop
    End If
    
End Function

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

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

'**********************************************************************************
'* Handles reading the win32 and win64 keys under the version key
'**********************************************************************************
Function FindWin3264(ByVal sPath As String)

    Dim vPlatforms As Variant: vPlatforms = Empty
    Call oWMIReg.EnumKey(HKCR, sPath, vPlatforms)
    
    
    If IsNull(vPlatforms) Then
        Dim sPlatform As String: sPlatform = ""
        sPlatform = GetRegString(sPath & "\" & "win32", "")
        vOutput(lRows, coWin32Binary) = sPlatform
        
        sPlatform = GetRegString(sPath & "\" & "win64", "")
        vOutput(lRows, coWin64Binary) = sPlatform

        Debug.Assert Len(vOutput(lRows, coWin32Binary)) + _
                Len(vOutput(lRows, coWin64Binary)) > 0
        
    Else
        Dim vPlatformLoop As Variant
        For Each vPlatformLoop In vPlatforms
            If Not FoundInPipes("Flags", vPlatformLoop) Then

                Dim sPlatformLoop As String: sPlatformLoop = ""
                sPlatformLoop = GetRegString(sPath & "\" & vPlatformLoop, "")

                If LCase(vPlatformLoop) = "win32" Then
                    vOutput(lRows, coWin32Binary) = sPlatformLoop
                ElseIf LCase(vPlatformLoop) = "win64" Then
                    vOutput(lRows, coWin64Binary) = sPlatformLoop
                Else
                    Stop
                End If
            End If
        Next
    End If


End Function

'**********************************************************************************
'* Syntactic sugar to wrap Instr
'**********************************************************************************
Function Found(ByVal String1 As String, ByVal String2 As String, _
        Optional Compare As VbCompareMethod = vbTextCompare) As Boolean
    Found = (InStr(1, String1, String2, Compare) > 0)
End Function


'**********************************************************************************
'* Syntactic sugar to wrap Instr
'**********************************************************************************
Function FoundInPipes(ByVal String1 As String, ByVal String2 As String, _
        Optional Compare As VbCompareMethod = vbTextCompare) As Boolean
    FoundInPipes = _
        (InStr(1, "|" & String1 & "|", "|" & String2 & "|", Compare) > 0)
End Function

Test post using video

So here we demonstrate how to place a Youtube video into a blog. This solution is taken from SO Iframe for Youtube and more officialy from w3schools.

Get Array Dimensions and Bounds (REDUX)

Previously, I opined on a Stack Overflow Q & A page where the classic interview question about finding the number of dimension for an array How to return the number of dimensions of a Variant array passed to it in VBA  On that SO Q & A you'll find my C# code that returns not just but actually the dimensions but also the bounds of the array's dimensions because that very frequentl follows.

But I want a pure VBA solution to paste into my projects, so here is some code.  We use the CopyMemory technique because this avoids using On Error Resume Next.

Option Explicit
Option Private Module

'http://stackoverflow.com/questions/24613101/vba-check-if-array-is-one-dimensional/26555865#26555865

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, _
        ByVal Source As Long, ByVal Length As Integer)

Public Function GetDimsAndBounds(VarSafeArray As Variant) As Scripting.Dictionary

    Dim dic As Scripting.Dictionary
    Set dic = New Scripting.Dictionary
    
    Dim lDims As Long
    lDims = GetDims(VarSafeArray)
    
    Dim lDimLoop As Long
    For lDimLoop = 1 To lDims
        
        ReDim bounds(0 To 1)
        bounds(0) = LBound(VarSafeArray, lDimLoop)
        bounds(1) = UBound(VarSafeArray, lDimLoop)
        dic.Add lDimLoop, bounds
    
    Next
    Set GetDimsAndBounds = dic

End Function

Public Function GetDims(VarSafeArray As Variant) As Integer
    Dim variantType As Integer
    Dim pointer As Long
    Dim arrayDims As Integer

    CopyMemory VarPtr(variantType), VarPtr(VarSafeArray), 2& 'the first 2 bytes of the VARIANT structure contain the type

    If (variantType And &H2000) > 0 Then 'Array (&H2000)
        'If the Variant contains an array or ByRef array, a pointer for the SAFEARRAY or array ByRef variant is located at VarPtr(VarSafeArray) + 8
        CopyMemory VarPtr(pointer), VarPtr(VarSafeArray) + 8, 4&

        'If the array is ByRef, there is an additional layer of indirection through another Variant (this is what allows ByRef calls to modify the calling scope).
        'Thus it must be dereferenced to get the SAFEARRAY structure
        If (variantType And &H4000) > 0 Then 'ByRef (&H4000)
            'dereference the pointer to pointer to get the actual pointer to the SAFEARRAY
            CopyMemory VarPtr(pointer), pointer, 4&
        End If
        'The pointer will be 0 if the array hasn't been initialized
        If Not pointer = 0 Then
            'If it HAS been initialized, we can pull the number of dimensions directly from the pointer, since it's the first member in the SAFEARRAY struct
            CopyMemory VarPtr(arrayDims), pointer, 2&
            GetDims = arrayDims
        Else
            GetDims = 0 'Array not initialized
        End If
    Else
        GetDims = 0 'It's not an array... Type mismatch maybe?
    End If
End Function

Use VBA.Collection instead of Scripting.Dictionary?

My code uses Scripting.Dictionary a lot, perhaps too much. Of late, I was wondering if I could wean myself off this dependency.

When called to explain some usages I say that I prefer it to VBA.Collection. When asked why I say I forgot and I really did forget. Lately, I've been using a VBA-JSON library module from Tim Hall. Tim's code excellently parses JSON in VBA to a nested structure of Scripting.Dictionaries and VBA.Collections.

Usually, I never use Collections but this code forced me to reacquaint and I found at least one problem in that I cannot set an item in a collection I must delete and re-add back into its position. This is a pain but here is some code.

Function ReplaceByIndex(ByVal col As VBA.Collection, ByVal idx As Long, ByRef vNew)
    
    If idx = 1 Then
        If col.Count = 1 Then
            col.Remove 1
            col.Add vNew
        Else
            '* nothing to go after so MUST use BEFORE
            col.Add vNew, , idx + 1
            col.Remove idx
        End If
    Else
        '* use After
        col.Remove idx
        col.Add vNew, , , idx - 1
    End If

End Function

Stop Using Scripting.Dictionary as an Array?

My code uses Scripting.Dictionary a lot, perhaps too much.  Of late, I was wondering if I could wean myself off this dependency.

When called to explain some usages I say that I really like using the Items() or the Keys() methods, they provide an array of variants ready to be pasted onto a sheet.

The bulk setter method for a Range is Range.Value (or Range.Value2).  I had thought that only a variant array works with this.  In the experiment below it turns out that one can supply an array of Strings, Dates, Double, Booleans etc.

It turns out the performance between pasting an array and pasting the Items from a Dictionary are very similar.  There is one key difference though for Dates, the Dictionary's output will format them as Dates whereas pasting an array of dates gives you doubles. A further experiment where we store dates in an array of Variants fixes the formatting bug (TIP!).

Later in the code are timing procedures, adjusting for a "cold start" it seems we can say that they are similarly fast.

So I guess only use Dictionary if you need the Exists() method because this is a feature that an array does not have.  Also from a strong typing point of view the Array does indicate its type (except where you use the tip of storing dates in variant for fixing format bug, see above).

Here is the code and you'll need a class from a Stack Overflow answer.  When pasted in run the procedure TestAll() with F5.

Option Explicit
Option Private Module

Private m_wsWork As Excel.Worksheet

Private Property Get mwsWork() As Excel.Worksheet
    If m_wsWork Is Nothing Then
        Set m_wsWork = Sheet3 '* &lt----- different for you
    End If
    Set mwsWork = m_wsWork
End Property

Private Sub TestAll()
    mwsWork.Rows("1:20").Delete
    '
    TestArrayOfStrings
    TestDictionaryOfStrings
    '
    TestArrayOfDates '* formats dates as double, boo!
    TestArrayOfDatesInVariants  '* formats dates as dates, hooray!
    TestDictionaryOfDates '* formats dates as dates
    '
    '* TIMIMGS
    '* warning, it seems the memory allocator needs to "warmed up"
    '* because the top of the following list suffers a cold start penalty
    '* (perhaps OS context switch is responsible)
    Dim l: For l = 1 To 20: TestTimingsOfDoubles False: Next l
    Debug.Print vbNewLine & "Timings:{"
    TestTimingsOfLongs True
    TestTimingsOfBooleans True
    TestTimingsOfDates True
    TestTimingsOfDatesInVariants True
    TestTimingsOfStrings True
    TestTimingsOfDoubles True
    Debug.Print "}"
    
End Sub

Private Sub TestArrayOfStrings()

    Dim lLoop As Long

    Dim arrayOfStrings() As String
    
    For lLoop = 1 To 5
        ReDim Preserve arrayOfStrings(1 To lLoop) '* Does this copy the array every time?
        arrayOfStrings(lLoop) = Chr$(64 + lLoop)
    Next lLoop

    mwsWork.Cells(1, 1).Value = "ArrayOfStrings"
    mwsWork.Cells(1, 2).Resize(1, 5).Value = arrayOfStrings
End Sub

Private Sub TestDictionaryOfStrings()

    Dim lLoop As Long
    Dim dicOfStrings As New Scripting.Dictionary
    
    For lLoop = 1 To 5
        dicOfStrings.Add dicOfStrings.Count, Chr$(64 + lLoop)
    Next lLoop


    mwsWork.Cells(3, 1).Value = "DictOfStrings"
    mwsWork.Cells(3, 2).Resize(1, 5).Value = dicOfStrings.Items
    
    'mwsWork.Cells(4, 2).Resize(1, 5).Value = dicOfStrings.Keys  '* Keys() also exports paste-able array
End Sub

Private Sub TestArrayOfDates()

    Dim lLoop As Long

    Dim arrayOfDates() As Date
    
    For lLoop = 1 To 5
        ReDim Preserve arrayOfDates(1 To lLoop) '* Does this copy the array every time?
        arrayOfDates(lLoop) = Now() + lLoop
    Next lLoop

    mwsWork.Cells(6, 1).Value = "ArrayOfDates"
    mwsWork.Cells(6, 2).Resize(1, 5).Value = arrayOfDates  '* despite use of Value and not Value2 dates get pasted as doubles
End Sub

Private Sub TestArrayOfDatesInVariants()

    Dim lLoop As Long

    Dim arrayOfDatesInVariants() As Variant
    
    For lLoop = 1 To 5
        ReDim Preserve arrayOfDatesInVariants(1 To lLoop) '* Does this copy the array every time?
        arrayOfDatesInVariants(lLoop) = Now() + lLoop
    Next lLoop

    mwsWork.Cells(7, 1).Value = "ArrayOfDatesInVariants"
    mwsWork.Cells(7, 2).Resize(1, 5).Value = arrayOfDatesInVariants  '* despite use of Value and not Value2 dates get pasted as doubles
End Sub

Private Sub TestDictionaryOfDates()
    'Debug.Assert VarType(Now() + 1) = vbDate   '* so we know the Dictionary is storing a date in its variant

    Dim lLoop As Long
    Dim dicOfDates As New Scripting.Dictionary
    
    For lLoop = 1 To 5
        dicOfDates.Add dicOfDates.Count, Now() + lLoop
    Next lLoop


    mwsWork.Cells(8, 1).Value = "DictOfDates"
    mwsWork.Cells(8, 2).Resize(1, 5).Value = dicOfDates.Items  '* gets pasted as dates
    

End Sub


Private Sub TestTimingsOfStrings(Optional bPrintResults As Boolean)
    Dim n As Long
    Dim oPM As PerformanceMonitor 'http://stackoverflow.com/questions/31383177/vba-queryperformancecounter-not-working#answer-31387007

    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    Dim lLoop As Long
    
    For n = 1 To 1000
        
        Dim dicOfStrings As Scripting.Dictionary
        Set dicOfStrings = New Scripting.Dictionary
        
        For lLoop = 1 To 50
            dicOfStrings.Add dicOfStrings.Count, Chr$(64 + lLoop)
        Next lLoop
    Next
    
    Dim vTimings(1 To 2) As Variant
    vTimings(1) = oPM.TimeElapsed
    
    Dim arrayOfStrings() As String
    
    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    
    For n = 1 To 1000
        
        
        For lLoop = 1 To 50
            ReDim Preserve arrayOfStrings(1 To lLoop) '* Does this copy the array every time?
            arrayOfStrings(lLoop) = Chr$(64 + lLoop)
        Next lLoop
    Next
    vTimings(2) = oPM.TimeElapsed

    If bPrintResults Then Debug.Print "Strings:{Dict:" & vTimings(1) & ", Array:" & vTimings(2) & "}"
    
    Set oPM = Nothing
End Sub


Private Sub TestTimingsOfDates(Optional bPrintResults As Boolean)
    Dim n As Long
    Dim oPM As PerformanceMonitor 'http://stackoverflow.com/questions/31383177/vba-queryperformancecounter-not-working#answer-31387007

    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    Dim lLoop As Long
    
    Debug.Assert VarType(Now() + 1) = vbDate   '* so we know the Dictionary is storing a date in its variant
    
    For n = 1 To 1000
        
        Dim dicOfDates As Scripting.Dictionary
        Set dicOfDates = New Scripting.Dictionary
        
        For lLoop = 1 To 50
            dicOfDates.Add dicOfDates.Count, Now() + lLoop
        Next lLoop
    Next
    
    Dim vTimings(1 To 2) As Variant
    vTimings(1) = oPM.TimeElapsed
    
    Dim arrayOfDates() As Date
    
    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    
    For n = 1 To 1000
        
        For lLoop = 1 To 50
            ReDim Preserve arrayOfDates(1 To lLoop) '* Does this copy the array every time?
            arrayOfDates(lLoop) = Now() + lLoop
        Next lLoop
    Next
    vTimings(2) = oPM.TimeElapsed
    If bPrintResults Then Debug.Print "Dates:{Dict:" & vTimings(1) & ", Array:" & vTimings(2) & "}"
    
    Set oPM = Nothing
End Sub


Private Sub TestTimingsOfDoubles(Optional bPrintResults As Boolean = False)
    Dim n As Long
    Dim oPM As PerformanceMonitor 'http://stackoverflow.com/questions/31383177/vba-queryperformancecounter-not-working#answer-31387007

    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    Dim lLoop As Long
    
    For n = 1 To 1000
        
        Dim dicOfDoubles As Scripting.Dictionary
        Set dicOfDoubles = New Scripting.Dictionary
        
        For lLoop = 1 To 50
            dicOfDoubles.Add dicOfDoubles.Count, 42802.6794444444
        Next lLoop
    Next
    
    Dim vTimings(1 To 2) As Variant
    vTimings(1) = oPM.TimeElapsed
    
    Dim arrayOfDoubles() As Double
    
    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    
    For n = 1 To 1000
        
        For lLoop = 1 To 50
            ReDim Preserve arrayOfDoubles(1 To lLoop) '* Does this copy the array every time?
            arrayOfDoubles(lLoop) = 42802.6794444444
        Next lLoop
    Next
    vTimings(2) = oPM.TimeElapsed
    If bPrintResults Then Debug.Print "Doubles:{Dict:" & vTimings(1) & ", Array:" & vTimings(2) & "}"
    
    Set oPM = Nothing
End Sub


Private Sub TestTimingsOfLongs(Optional bPrintResults As Boolean)
    Dim n As Long
    Dim oPM As PerformanceMonitor 'http://stackoverflow.com/questions/31383177/vba-queryperformancecounter-not-working#answer-31387007

    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    Dim lLoop As Long
    
    For n = 1 To 1000
        
        Dim dicOfLongs As Scripting.Dictionary
        Set dicOfLongs = New Scripting.Dictionary
        
        For lLoop = 1 To 50
            dicOfLongs.Add dicOfLongs.Count, 130691232#
        Next lLoop
    Next
    
    Dim vTimings(1 To 2) As Variant
    vTimings(1) = oPM.TimeElapsed
    
    Dim arrayOfLongs() As Long
    
    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    
    For n = 1 To 1000
        
        For lLoop = 1 To 50
            ReDim Preserve arrayOfLongs(1 To lLoop) '* Does this copy the array every time?
            arrayOfLongs(lLoop) = 130691232#
        Next lLoop
    Next
    vTimings(2) = oPM.TimeElapsed
    If bPrintResults Then Debug.Print "Longs:{Dict:" & vTimings(1) & ", Array:" & vTimings(2) & "}"
    
    Set oPM = Nothing
End Sub

Private Sub TestTimingsOfBooleans(Optional bPrintResults As Boolean)
    Dim n As Long
    Dim oPM As PerformanceMonitor 'http://stackoverflow.com/questions/31383177/vba-queryperformancecounter-not-working#answer-31387007

    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    Dim lLoop As Long
    
    For n = 1 To 1000
        
        Dim dicOfBooleans As Scripting.Dictionary
        Set dicOfBooleans = New Scripting.Dictionary
        
        For lLoop = 1 To 50
            dicOfBooleans.Add dicOfBooleans.Count, True
        Next lLoop
    Next
    
    Dim vTimings(1 To 2) As Variant
    vTimings(1) = oPM.TimeElapsed
    
    Dim arrayOfBooleans() As Boolean
    
    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    
    For n = 1 To 1000
        
        For lLoop = 1 To 50
            ReDim Preserve arrayOfBooleans(1 To lLoop) '* Does this copy the array every time?
            arrayOfBooleans(lLoop) = True
        Next lLoop
    Next
    vTimings(2) = oPM.TimeElapsed
    If bPrintResults Then Debug.Print "Booleans:{Dict:" & vTimings(1) & ", Array:" & vTimings(2) & "}"
    
    Set oPM = Nothing
End Sub


Private Sub TestTimingsOfDatesInVariants(Optional bPrintResults As Boolean)
    Dim n As Long
    Dim oPM As PerformanceMonitor 'http://stackoverflow.com/questions/31383177/vba-queryperformancecounter-not-working#answer-31387007

    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    Dim lLoop As Long
    
    Debug.Assert VarType(Now() + 1) = vbDate   '* so we know the Dictionary is storing a date in its variant
    
    For n = 1 To 1000
        
        Dim dicOfDates As Scripting.Dictionary
        Set dicOfDates = New Scripting.Dictionary
        
        For lLoop = 1 To 50
            dicOfDates.Add dicOfDates.Count, Now() + lLoop
        Next lLoop
    Next
    
    Dim vTimings(1 To 2) As Variant
    vTimings(1) = oPM.TimeElapsed
    
    Dim arrayOfDates() As Variant
    
    Set oPM = New PerformanceMonitor
    oPM.StartCounter
    
    For n = 1 To 1000
        
        For lLoop = 1 To 50
            ReDim Preserve arrayOfDates(1 To lLoop) '* Does this copy the array every time?
            arrayOfDates(lLoop) = Now() + lLoop
        Next lLoop
    Next
    vTimings(2) = oPM.TimeElapsed
    If bPrintResults Then Debug.Print "DatesInVariants:{Dict:" & vTimings(1) & ", Array:" & vTimings(2) & "}"
    
    Set oPM = Nothing
End Sub