VBA - Windows Script Host Object Model - Timed Popups

So Windows Script Host Object Model has a timed popup message box which is great if it worked as described. The bug lies in the duration, from VBA one can call asking for a popup to be timed to one second but it hangs around much longer, say 5-8 seconds. The solution, as found on StackOverflow, is to shell a HTML Application (HTA) which runs the command.

It is a shame this does not work flawlessly because otherwise we could advocate it to those Excel programmers who like to throw message boxes. Be aware that if you run an Excel VBA application unattended, say on a server, then there is nobody there to dismiss any message boxes and so processes can get stuck. Timed popus allow an application to proceed even when unattended.

Option Explicit

Sub TestTimedPopup()


    Dim oShell As IWshRuntimeLibrary.WshShell
    Set oShell = New IWshRuntimeLibrary.WshShell
    
    '* this hangs around for a period longer than 1 second, up to 8 seconds!!!
    oShell.Popup "Hello world, gonna hang around for longer than 1 second", 1, "mytitle", 0
    


End Sub

Sub TestTimedPopup2()

    '* with thanks to stackoverflow.com
    'https://stackoverflow.com/questions/31141775/infobox-popup-refuses-to-close-on-timer-expiration#answer-31143673

    Dim oShell As IWshRuntimeLibrary.WshShell
    Set oShell = New IWshRuntimeLibrary.WshShell

    '* in case you are wondering c:\windows\SysWOW64\mshta.exe
    '* is the Microsoft HTML Application host, part of the Internet Explorer product suite
    '* it allows running vbscript and javascript outside a web browser's sandbox
    oShell.Run "mshta.exe vbscript:close(CreateObject(""WScript.shell"").Popup(""Hello world, gonna hang for exactly 1 second"",1,""mytitle""))"

    '* HTA Developers page is mothballed so you 'll need to use an Internet archive , try this
    '* https://web.archive.org/web/20070305033902/http://www.microsoft.com:80/technet/scriptcenter/topics/htas/tutorial1.mspx

End Sub

VBA - Windows Script Host Object Model - Network

So the Windows Script Host Object Model is a great COM library scriptable in VBA with plenty of features worth blogging. First up we can show the Network object. This can give a user's computer name and also help query if the user is logged onto an enterprise network (which may influence licensing).

    
Sub Illustrating_WshNetwork()
    '* Tools->References Windows Script Host Object Model   (C:\Windows\SysWOW64\wshom.ocx)
    Dim oNetwork As New IWshRuntimeLibrary.WshNetwork
    
    Dim sOrganization As String, sSite As String, sUserProfile As String
    sOrganization = "#N/A"
    sSite = "#N/A"
    sUserProfile = "#N/A"
    SafeGetNetworkOrganizationSiteUserProfile oNetwork, sOrganization, sSite, sUserProfile
    
    Debug.Print "ComputerName:" & oNetwork.ComputerName
    Debug.Print "UserName:" & oNetwork.UserName
    Debug.Print "UserDomain:" & oNetwork.UserDomain
    Debug.Print "Site:" & sSite
    Debug.Print "Organization:" & sOrganization
    Debug.Print "UserProfile:" & sUserProfile
    
    Stop
    

End Sub

Sub SafeGetNetworkOrganizationSiteUserProfile(ByVal oNetwork As WshNetwork, _
                    ByRef psOrganization As String, ByRef psSite As String, ByRef psUserProfile As String)
    On Error Resume Next
    
    psOrganization = oNetwork.Organization
    psSite = oNetwork.Site
    psUserProfile = oNetwork.UserProfile


End Sub

VBA - Use Application.OnTime to mimic multitasking (redux) - WSH instead of Windows API

So something about the last post troubled me, I knew there was a better library out there for shelling and getting exit codes, running status etc. without resorting to the Windows API

The library I was missing was Windows Script Host Object Model (c:\Windows\SysWOW64\wshom.ocx) which beautifully gives a shelled process' running status, process id and also stdin, stdout, stderr pipes. It's quite curious as it is a Microsoft library but the description does not begin with Microsoft so not obvious whilst browsing Tools->References.

So we can write a cleaner version of the previous post thus ...

Option Explicit

Private moExec As IWshRuntimeLibrary.WshExec
Private mdicBackgroundTask As New Scripting.Dictionary



Sub LaunchNotePadAndDoBackgroundWork()
    
    Dim oShell As IWshRuntimeLibrary.WshShell
    Set oShell = New IWshRuntimeLibrary.WshShell
    
    Set moExec = oShell.Exec("notepad.exe")
    
    If moExec.ProcessID > 0 Then
        '* delete the dictionary resets the state
        Set mdicBackgroundTask = Nothing
        
        mdicBackgroundTask("MaxSeconds") = 5
        Application.OnTime Now(), "SomeTaskToGetOnWith"
        
        While Not mdicBackgroundTask("Cancel")
            '* yield control to OnTime scheduled procedures
            DoEvents
            
            '* check for cancel here for cases when background task stop scheduling it
            '* even if that means checking more than once
            CheckForCancel
        Wend
        Debug.Print "process terminated"
    End If
    
    DoEvents
End Sub

Sub CheckForCancel()
    '* seems that we need to put this in the OnTime queue otherwise never gets checked
    
    Dim bCancel As Boolean
    
    If moExec Is Nothing Then
        bCancel = True
    Else
        If moExec.Status <> WshRunning Then
            bCancel = True
        End If
    End If

    If bCancel Then
        mdicBackgroundTask("Cancel") = True
        Debug.Print "Process exited, request cancel"
    End If
End Sub

Sub SomeTaskToGetOnWith()
    DoEvents
    If mdicBackgroundTask("Cancel") = True Then
        Debug.Print "no more, cancel requested"
    Else
    
        If Not mdicBackgroundTask.Exists("TaskRun") Then
           
            mdicBackgroundTask("Started") = Now
            mdicBackgroundTask("TaskRun") = True
            
            '* ensure MaxSeconds has something sensible
            If Not mdicBackgroundTask.Exists("MaxSeconds") Then
                mdicBackgroundTask("MaxSeconds") = 1
            ElseIf mdicBackgroundTask("MaxSeconds") <= 0 Then
                mdicBackgroundTask("MaxSeconds") = 1
            End If
            
        End If
        
        Dim l As Long
        For l = 1 To 10
            
            Debug.Print Rnd()
        Next l
    
    
        '* some less simple logic to steop this task rescheduling forever
        If Abs(VBA.DateDiff("s", mdicBackgroundTask("Started"), Now())) <= mdicBackgroundTask("MaxSeconds") Then
        
            Application.OnTime Now(), "CheckForCancel"
            Application.OnTime Now(), "SomeTaskToGetOnWith"
            Debug.Print "rescheduled"
        Else
            Debug.Print "no more rescheduling done enough work, " & mdicBackgroundTask("MaxSeconds") & " seconds."
        End If
    
    End If
    
End Sub

VBA - Using Application.OnTime to mimic multitasking

I saw someone else's blog today that launched a process and checked the error code to see when it terminates, they suggested waiting between each check. We can do better than that. We can schedule snippets of work using Application.OnTime which can reschedule themselves to keep going.

But we need to know when to stop, so we need a Cancel checking routine, it turns out you'll need to check the cancel also in a procedure scheduled with OnTime. Only when OnTime scheduled procedures have been exhausted does control return to the "normal" code.

This is actually better described as timeslicing, since VBA is single threaded. Using this technique, we can give the illusion of multiple tasks going on. This is fine because all the user really cares about is a responsive GUI.

Option Explicit

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

Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
                    (ByVal hProcess As LongPtr, lpExitCode As Long) As Long

Private mdicBackgroundTask As New Scripting.Dictionary

Sub LaunchNotePadAndDoBackgroundWork()
    Dim hProg As Long
    Dim hProc As Long
    Const PROCESS_ALL_ACCESS As Long = &H0
    Const SYNCHRONIZE As Long = &H100000
    Const PROCESS_QUERY_LIMITED_INFORMATION As Long = &H1000
    Const INFINITE As Long = &HFFFF
    'hProg = Shell(Environ("comspec") & " /s /c notepad.exe ")
    hProg = Shell("notepad.exe", vbNormalFocus)

        
    
    hProc = OpenProcess(SYNCHRONIZE + PROCESS_QUERY_LIMITED_INFORMATION, False, hProg)
    If hProc > 0 Then
        '* delete the dictionary resets the state
        Set mdicBackgroundTask = Nothing
        
        mdicBackgroundTask("MaxSeconds") = 5
        mdicBackgroundTask("hProc") = hProc
        Application.OnTime Now(), "SomeTaskToGetOnWith"
        
        While Not mdicBackgroundTask("Cancel")
            '* yield control to OnTime scheduled procedures
            DoEvents
            
            '* check for cancel here for cases when background task stop scheduling it
            '* even if that means checking more than once
            CheckForCancel
        Wend
        Debug.Print "process terminated"
        CloseHandle hProc
    End If
    
    DoEvents
End Sub

Sub CheckForCancel()
    '* seems that we need to put this in the OnTime queue otherwise never gets checked
    Dim lRetVal As Long
    GetExitCodeProcess mdicBackgroundTask("hProc"), lRetVal
    If lRetVal = 0 Then
        mdicBackgroundTask("Cancel") = True
        Debug.Print "Process exited, request cancel"
    End If
End Sub

Sub SomeTaskToGetOnWith()
    DoEvents
    If mdicBackgroundTask("Cancel") = True Then
        Debug.Print "no more, cancel requested"
    Else
    
        If Not mdicBackgroundTask.Exists("TaskRun") Then
           
            mdicBackgroundTask("Started") = Now
            mdicBackgroundTask("TaskRun") = True
            
            '* ensure MaxSeconds has something sensible
            If Not mdicBackgroundTask.Exists("MaxSeconds") Then
                mdicBackgroundTask("MaxSeconds") = 1
            ElseIf mdicBackgroundTask("MaxSeconds") <= 0 Then
                mdicBackgroundTask("MaxSeconds") = 1
            End If
            
        End If
        
        Dim l As Long
        For l = 1 To 10
            
            Debug.Print Rnd()
        Next l
    
    
        '* some less simple logic to steop this task rescheduling forever
        If Abs(VBA.DateDiff("s", mdicBackgroundTask("Started"), Now())) <= mdicBackgroundTask("MaxSeconds") Then
        
            Application.OnTime Now(), "CheckForCancel"
            Application.OnTime Now(), "SomeTaskToGetOnWith"
            Debug.Print "rescheduled"
        Else
            Debug.Print "no more rescheduling done enough work, " & mdicBackgroundTask("MaxSeconds") & " seconds."
        End If
    
    End If
    
End Sub

.NET Framework objects in VBA

So from time to time I see a snippet of code which clearly shows a .NET Framework class being instantiated and its methods called on from VBA. At some point I will investigate just how widespread this technique can be used, in the meantime I am going to on this page collect code snippets.

ArrayList

The ArrayList is a useful collections object which could replace Scripting.Dictionary. Here is some code...

Sub TestDotNetArrayList()
    
    Dim oArrayList As Object
    Set oArrayList = CreateObject("System.Collections.ArrayList")
    oArrayList.add "c"
    oArrayList.add "a"
    oArrayList.add "b"
    Debug.Assert oArrayList.Item(0) = "c"
    Debug.Assert oArrayList.Item(1) = "a"
    Debug.Assert oArrayList.Item(2) = "b"
    
    oArrayList.Sort

    '* now sorted
    Debug.Assert oArrayList.Item(0) = "a"
    Debug.Assert oArrayList.Item(1) = "b"
    Debug.Assert oArrayList.Item(2) = "c"

End Sub

StringBuilder

The StringBuilder has a VBA equivalent of Mid$ but if you really want the .NET class then below is some code. Note Intellisense is not available and you'll have to research the method overload.

Sub TestDotNetStringBuilder()

    Dim oSB As Object
    Set oSB = CreateObject("System.Text.StringBuilder")
    
    oSB.AppendFormat_5 Nothing, "hello {0}", Array("simon")
    Debug.Assert oSB.tostring = "hello simon"
    
End Sub

SortedList

There is also a SortedList which takes key value pairs but which can be difficult to access. Here I use one to sort an ordinary Scripting.Dictionary

Sub TestSortDictionary()

    Dim dicIn As Scripting.Dictionary
    Set dicIn = New Scripting.Dictionary
    
    dicIn.Add "foo", 12
    dicIn.Add "bar", 11

    Debug.Assert dicIn.Keys()(0) = "foo"
    Debug.Assert dicIn.Keys()(1) = "bar"

    Set dicIn = SortDictionary(dicIn)
    
    Debug.Assert dicIn.Keys()(0) = "bar"
    Debug.Assert dicIn.Keys()(1) = "foo"
    

End Sub

Function SortDictionary(ByVal dicIn As Scripting.Dictionary) As Scripting.Dictionary

    Dim dicSorted As Scripting.Dictionary
    Set dicSorted = New Scripting.Dictionary
    
    Dim objSortedList As Object ' mscorlib.SortedList
    Set objSortedList = CreateObject("System.Collections.SortedList") 'New mscorlib.SortedList
    
    
    Dim vKeyLoop As Variant
    For Each vKeyLoop In dicIn.Keys
        objSortedList.Add vKeyLoop, dicIn(vKeyLoop)
    
    Next
    
    Dim lKeyLoop As Long
    For lKeyLoop = 0 To dicIn.Count - 1
        
        Dim vKey As Variant
        vKey = objSortedList.GetKeyList()(lKeyLoop)
        
        dicSorted.Add vKey, dicIn(vKey)
    
    Next lKeyLoop
    
    Set SortDictionary = dicSorted
End Function

TODO: some sample code for System.Security.Cryptography.HMACSHA256

To be honest given the naming convention of .NET library where everything starts with System. then one can peruse the registry from others.

Links

• VBA voor smarties SortedList

VBA - Ease Xml debugging wth Xml document pretty print

I like Xml and will frequently choose to work with an Xml document carrying data rather than define a ton of type definitions in VBA but this means the Locals and the Watches window show a big blob of a string. So I like to write a function to pretty print the Xml document for output to the Immediate window. Here is it

Option Explicit

Function PrettyPrintXml(ByVal dom As MSXML2.DOMDocument60) As String

    Dim reader As MSXML2.SAXXMLReader60
    Set reader = New MSXML2.SAXXMLReader60
    
    Dim writer As MSXML2.MXXMLWriter60
    Set writer = New MSXML2.MXXMLWriter60
    writer.omitXMLDeclaration = True
    writer.indent = True

    reader.PutProperty "http://xml.org/sax/properties/lexical-handler", writer
    
    Set reader.contentHandler = writer
    reader.Parse dom.XML
   
    PrettyPrintXml = writer.output
End Function

Private Sub TestPrettyPrintXml()

    Dim sSampleXml As String
    sSampleXml = "<note><to>Tove</to><from>Jani</from>" & _
        "<heading>Reminder</heading><body>Don't forget me this weekend!</body></note>"

    Dim dom As MSXML2.DOMDocument60
    Set dom = New MSXML2.DOMDocument60
    dom.LoadXML sSampleXml
    Debug.Assert dom.parseError.ErrorCode = 0
    
    Dim sPrettified As String
    sPrettified = PrettyPrintXml(dom)
    
    Debug.Print sPrettified
    
    Dim vSplitLines As Variant
    vSplitLines = VBA.Split(sPrettified, vbNewLine)
    
    Debug.Assert vSplitLines(0) = ""
    Debug.Assert vSplitLines(1) = vbTab & "Tove"
    Debug.Assert vSplitLines(2) = vbTab & "Jani"
    Debug.Assert vSplitLines(3) = vbTab & "Reminder"
    Debug.Assert vSplitLines(4) = vbTab & "Don't forget me this weekend!"
    Debug.Assert vSplitLines(5) = ""
End Sub

VBA - Fast Serialization of Cells to JSON

As a counterpart to the previous post serializing cells to Excel's array literal string here I present serialization to JSON.

We ought to remind ourselves how to parse a JSON array with built in Microsoft ScriptControl thus ...

Sub IllustratingJSONParsing()
    '* Tools->References->Microsoft Script Control 1.0   (msscript.ocx)
    Dim oScriptControl As MSScriptControl.ScriptControl
    Set oScriptControl = New MSScriptControl.ScriptControl
    oScriptControl.Language = "javascript"
    
    Dim oParsed As Object
    Set oParsed = oScriptControl.Eval("([[""a"",""b"",3],[""d"",5.1,""f""]])")
    
    Debug.Assert CallByName(oParsed, "length", VbGet) = 2
    
    Dim oRow0 As Object
    Set oRow0 = CallByName(oParsed, 0, VbGet)
    Debug.Assert CallByName(oRow0, "length", VbGet) = 3
    Debug.Assert CallByName(oRow0, "0", VbGet) = "a"
    Debug.Assert CallByName(oRow0, "1", VbGet) = "b"
    Debug.Assert CallByName(oRow0, "2", VbGet) = 3
    
    Dim oRow1 As Object
    Set oRow1 = CallByName(oParsed, 1, VbGet)
    Debug.Assert CallByName(oRow1, "length", VbGet) = 3
    Debug.Assert CallByName(oRow1, "0", VbGet) = "d"
    Debug.Assert CallByName(oRow1, "1", VbGet) = 5.1
    Debug.Assert CallByName(oRow1, "2", VbGet) = "f"
End Sub

And the code to serialize is very similar to the previous post and is fast because it uses Mid$ as a left hand side operator. Enjoy!

Option Explicit

'VBA - Fast Serialization of Cells to JSON


Function GetRangeJSON(ByVal rngSource As Excel.Range)
    Const CELL_LENGTH = 257 'Add 2 for double quotes
    
    With rngSource
        Dim lRows As Long
        lRows = .Rows.Count
        
        Dim lColumns As Long
        lColumns = .Columns.Count
        
        Dim lBufferSize As Long
        lBufferSize = CELL_LENGTH * .Cells.Count + lRows + (lRows * lColumns)
    End With
    
    '* initialise the buffer with spaces then start opening brace
    Dim sText As String
    sText = VBA.Space(lBufferSize)
    
    Dim lCursor As Long
    lCursor = 1
    Mid$(sText, lCursor, 1) = "["
    
    Dim vData()
    vData = rngSource.Value

    Dim lRow As Long
    For lRow = 1 To lRows
    
    
        '* if past first row then we need a row continuation
        If lRow > 1 Then
            lCursor = lCursor + 1
            Mid$(sText, lCursor, 1) = ","
        End If

        lCursor = lCursor + 1
        Mid$(sText, lCursor, 1) = "["


        Dim lColumn As Long
        For lColumn = 1 To lColumns
            
            Dim vCell As Variant
            vCell = vData(lRow, lColumn)
            
            Dim lCellLength As Long
            lCellLength = Len(vCell)
            
            '* extend buffer if necessary
            If lCursor + lCellLength + 2 > Len(sText) Then sText = sText & Space(CDbl(lBufferSize / 4))
            
            '* if past first column then we need a cell continuation
            If lColumn > 1 Then
                lCursor = lCursor + 1
                Mid(sText, lCursor, 1) = ","
            End If

    
            '* write in value directly into buffer, wrap quotes around strings
            If (VBA.TypeName(vCell) = "String") Then
                lCellLength = lCellLength + 2
                Mid$(sText, lCursor + 1, lCellLength) = """" & vCell & """"
            Else
                Mid$(sText, lCursor + 1, lCellLength) = vCell
            End If
            
            '* increment cursor
            lCursor = lCursor + lCellLength
        Next
        
        lCursor = lCursor + 1
        Mid$(sText, lCursor, 1) = "]"
        
    Next

    GetRangeJSON = Left$(sText, lCursor) & "]"
End Function

Function TestGetRangeJson()
    
    Dim rng As Excel.Range
    Set rng = ThisWorkbook.Worksheets.Item(4).Range("c3:e4")
    rng.Cells(1, 1) = "a"
    rng.Cells(1, 2) = "b"
    rng.Cells(1, 3) = 3
    rng.Cells(2, 1) = "d"
    rng.Cells(2, 2) = 5.1
    rng.Cells(2, 3) = "f"
    
    Dim sRange As String
    sRange = GetRangeJSON(rng)
    
    Debug.Assert sRange = "[[""a"",""b"",3],[""d"",5.1,""f""]]"
    
    Dim oScriptControl As MSScriptControl.ScriptControl
    Set oScriptControl = New MSScriptControl.ScriptControl
    oScriptControl.Language = "javascript"
    
    Dim oParsed As Object
    Set oParsed = oScriptControl.Eval(sRange)
    
    
    Debug.Assert CallByName(oParsed, "length", VbGet) = 2
    
    Dim oRow0 As Object
    Set oRow0 = CallByName(oParsed, 0, VbGet)
    Debug.Assert CallByName(oRow0, "length", VbGet) = 3
    Debug.Assert CallByName(oRow0, "0", VbGet) = "a"
    Debug.Assert CallByName(oRow0, "1", VbGet) = "b"
    Debug.Assert CallByName(oRow0, "2", VbGet) = 3
    
    Dim oRow1 As Object
    Set oRow1 = CallByName(oParsed, 1, VbGet)
    Debug.Assert CallByName(oRow1, "length", VbGet) = 3
    Debug.Assert CallByName(oRow1, "0", VbGet) = "d"
    Debug.Assert CallByName(oRow1, "1", VbGet) = 5.1
    Debug.Assert CallByName(oRow1, "2", VbGet) = "f"
    
    
End Function

VBA - Fast Serialization of Cells to Array Literal String

Today on StackOverflow I saw a great answer which utilizes Mid$() as a left hand operator to write into a string buffer. Concatenating strings is always slow and this is why languages such as C# and Java have a StringBuilder class. Using Mid$() on the left hand side of an assignment is VBA's equivalent of StringBuilder.

We can use this Mid$ (StringBuilder) to very quickly serialize a block of cells to an array literal which can be used to save fragments to file or for marshalling across to a web service

As a reminder array literal strings can be passed to Application.Evaluate and so parsed into an array ready to be pasted to cells. They are quite a simple format, the columns are comma separated and the rows semi-colon sepated, strings are quoted and the whole block is wrapped into curly brackets thus ...

Sub IllustratingApplicationEvaluateAndLiterals()
    
    Dim v As Variant
    v = Application.Evaluate("{""a"",""b"",3;""d"",5.1,""f""}")
    
    Debug.Assert v(1, 1) = "a"
    Debug.Assert v(1, 2) = "b"
    Debug.Assert v(1, 3) = 3
    Debug.Assert v(2, 1) = "d"
    Debug.Assert v(2, 2) = 5.1
    Debug.Assert v(2, 3) = "f"
    
End Sub

So now some code to take cells and serialize into an array literal string

Function GetRangeLiteral(ByVal rngSource As Excel.Range)
    Const CELL_LENGTH = 257 'Add 2 for double quotes
    
    With rngSource
        Dim lRows As Long
        lRows = .Rows.Count
        
        Dim lColumns As Long
        lColumns = .Columns.Count
        
        Dim lBufferSize As Long
        lBufferSize = CELL_LENGTH * .Cells.Count + lRows + (lRows * lColumns)
    End With
    
    '* initialise the buffer with spaces then start opening brace
    Dim sText As String
    sText = VBA.Space(lBufferSize)
    Mid$(sText, 1, 1) = "{"
    
    Dim lCursor As Long
    lCursor = 1
    
    Dim vData()
    vData = rngSource.Value

    Dim lRow As Long
    For lRow = 1 To lRows
    
        '* if past first row then we need a row continuation
        If lRow > 1 Then
            lCursor = lCursor + 1
            Mid$(sText, lCursor, 1) = ";"
        End If

        Dim lColumn As Long
        For lColumn = 1 To lColumns
            
            Dim vCell As Variant
            vCell = vData(lRow, lColumn)
            
            Dim lCellLength As Long
            lCellLength = Len(vCell)
            
            '* extend buffer if necessary
            If lCursor + lCellLength + 2 > Len(sText) Then sText = sText & Space(CDbl(lBufferSize / 4))
            
            '* if past first column then we need a cell continuation
            If lColumn > 1 Then
                lCursor = lCursor + 1
                Mid(sText, lCursor, 1) = ","
            End If

    
            '* write in value directly into buffer, wrap quotes around strings
            If (VBA.TypeName(vCell) = "String") Then
                lCellLength = lCellLength + 2
                Mid$(sText, lCursor + 1, lCellLength) = """" & vCell & """"
            Else
                Mid$(sText, lCursor + 1, lCellLength) = vCell
            End If
            
            '* increment cursor
            lCursor = lCursor + lCellLength
        Next
    Next

    GetRangeLiteral = Left$(sText, lCursor) & "}"
End Function

Function TestGetRangeLiteral()
    
    Dim rng As Excel.Range
    Set rng = ThisWorkbook.Worksheets.Item(4).Range("c3:e4")
    rng.Cells(1, 1) = "a"
    rng.Cells(1, 2) = "b"
    rng.Cells(1, 3) = 3
    rng.Cells(2, 1) = "d"
    rng.Cells(2, 2) = 5.1
    rng.Cells(2, 3) = "f"
    
    Dim sRange As String
    sRange = GetRangeLiteral(rng)
    
    Debug.Assert sRange = "{""a"",""b"",3;""d"",5.1,""f""}"
    
    Dim v As Variant
    v = Application.Evaluate(sRange)
    Debug.Assert v(1, 1) = "a"
    Debug.Assert v(1, 2) = "b"
    Debug.Assert v(1, 3) = 3
    Debug.Assert v(2, 1) = "d"
    Debug.Assert v(2, 2) = 5.1
    Debug.Assert v(2, 3) = "f"
    
End Function

VBA - Convert Long Hexadecimal to Long Decimal String

So with cryptography one may have to work with very long numbers that bust the maximum size of VBA intrinsic types. What is needed is sometimes informally called BigInteger and formally called Arbitrary Precision Arithmetic Now one could go for a whole library but for a narrow use case then sometimes a code snippett does the job.

The following code is based on a StackOverflow question Convert a “big” Hex number (string format) to a decimal number (string format) without BigInteger Class. The answer was given in C# but converted to VBA for this blog.

Function HexToDecimal(ByVal sHex As String) As String

    Dim dec() As Long
    ReDim dec(0 To 0) As Long
    
    Dim lCharLoop As Long
    For lCharLoop = 1 To Len(sHex)
        
        Dim char As String * 1
        char = Mid$(sHex, lCharLoop, 1)
        
        Dim carry As Long
        carry = Val("&h" & char)
        
        Dim i As Long
        For i = 0 To UBound(dec)
            Dim lVal As Long
            lVal = dec(i) * 16 + carry
            dec(i) = lVal Mod 10
            carry = lVal \ 10
        Next i
    
        While (carry > 0)
            ReDim Preserve dec(0 To UBound(dec) + 1) As Long
            dec(UBound(dec)) = carry Mod 10
            carry = carry \ 10
        Wend
    Next
    
    For lCharLoop = UBound(dec) To LBound(dec) Step -1
        Dim sDecimal As String
        sDecimal = sDecimal & Chr$(48 + dec(lCharLoop))
    
    Next
    
    HexToDecimal = sDecimal

End Function

Private Sub TestHexToDecimal()

    Debug.Assert HexToDecimal("F") = "15"
    Debug.Assert HexToDecimal("4") = CStr(Val("&H4"))
    Debug.Assert HexToDecimal("10") = CStr(Val("&H10"))
    Debug.Assert HexToDecimal("20") = CStr(Val("&H20"))
    Debug.Assert HexToDecimal("30") = CStr(Val("&H30"))
    Debug.Assert HexToDecimal("40") = CStr(Val("&H40"))
    Debug.Assert HexToDecimal("44") = CStr(Val("&H44"))
    Debug.Assert HexToDecimal("FF") = "255"
    Debug.Assert HexToDecimal("FFF") = "4095"
    Debug.Assert HexToDecimal("443") = CStr(Val("&H443"))
    Debug.Assert HexToDecimal("443C1") = "279489"
    Debug.Assert HexToDecimal("443C1CE20DFD592FB374D829B894BBE5") = "90699627342249584016268008583970733029"

    Debug.Assert HexToDecimal("EC851A69B8ACD843164E10CFF70CF9E86DC2FEE3CF6F374B43C854E3342A2F1AC3E30" & _
    "C741CC41E679DF6D07CE6FA3A66083EC9B8C8BF3AF05D8BDBB0AA6CB3EF8C5BAA2A5" & _
    "E531BA9E28592F99E0FE4F95169A6C63F635D0197E325C5EC76219B907E4EBDCD401FB1" & _
    "986E4E3CA661FF73E7E2B8FD9988E753B7042B2BBCA76679") = _
    "1660899461379861685353688491843017402046137536931563604625752175601309049219" & _
    "5397632483978280801827700029602706087374780329179786968451649489474169926767" & _
    "4246881622658654267131250470956587908385447044319923040838072975636163137212" & _
    "8878242485755103411040294617585948551591743298921259938445664971761026682621" & _
    "39513"

End Sub

JSON to Excel Cells Serialization

So JSON is becoming a popular serialization format to rival (if not overtake) XML for web services. If you're an Excel VBA programmer and you want to dump some JSON into cells then you could use the ScriptControl to parse this, see my blog entry here. However, it is worth pointing out that Excel has a cell value serialization format which call be demonstrated thus ...

Sub XlSerialization1()
    Dim v
    v = [{1,2;"foo",4.5}]

    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = 2
    Debug.Assert v(2, 1) = "foo"
    Debug.Assert v(2, 2) = 4.5

    '* write all cells in one line
    Sheet1.Cells(1, 1).Resize(2, 2).Value2 = v
End Sub

So the square brackets surround the curly bracketed expression, square brackets is a VBA shorthand for evaluate, so the core syntax is the curly-bracketed expression. The given form is for literals where the cell values are constant. What happens when you want to use a variable, this is when you need Application.Evaluate thus ...

Sub XlSerialization2()

    Dim s As String
    s = "{1,2;""foo"",4.5}"
    
    Dim appEval
    appEval = Application.Evaluate(s)

    Debug.Assert appEval(1, 1) = 1
    Debug.Assert appEval(1, 2) = 2
    Debug.Assert appEval(2, 1) = "foo"
    Debug.Assert appEval(2, 2) = 4.5

    '* write all cells in one line
    Sheet1.Cells(4, 1).Resize(2, 2).Value2 = appEval
End Sub

If we want to write a 2D JSON array to cells we can convert the JSON string to this Excel serialization string and then we can get a Variant in one step and write the Variant in one step. For large arrays I should think this would be faster than looping through each element in VBA.

It might be possible to use regular expressions to extract and convert the cells values but instead I chose let a JavaScript engine/parser parse a JSON string and leveraged this thus...

Sub TestJSONArrayToXlArray()
    
    '* [[1,2],[3,4]] is a JSON 2D array, ideal for writing to cells
    Dim vXlArray As Variant
    vXlArray = JsonArrayToXlArray("[[1,2],[3,4]]")

    Debug.Assert vXlArray(1, 1) = 1
    Debug.Assert vXlArray(1, 2) = 2
    Debug.Assert vXlArray(2, 1) = 3
    Debug.Assert vXlArray(2, 2) = 4

    
    '* write all cells in one line
    Sheet1.Cells(1, 4).Resize(2, 2).Value2 = vXlArray


    '* [['foo','bar'],['baz','barry']] is a JSON 2D array, ideal for writing to cells
    Dim vXlArray2 As Variant
    vXlArray2 = JsonArrayToXlArray(Replace("[['foo','bar'],['baz','barry']]", "'", """"))

    Debug.Assert vXlArray2(1, 1) = "foo"
    Debug.Assert vXlArray2(1, 2) = "bar"
    Debug.Assert vXlArray2(2, 1) = "baz"
    Debug.Assert vXlArray2(2, 2) = "barry"

    '* write all cells in one line
    Sheet1.Cells(4, 4).Resize(2, 2).Value2 = vXlArray2


End Sub

Private Function JsonArrayToXlArray(sJson2dArray As String) As Variant
    
    Static oScriptEngine As ScriptControl
    If oScriptEngine Is Nothing Then
        Set oScriptEngine = New ScriptControl
        oScriptEngine.Language = "JScript"
        oScriptEngine.AddCode "function quoteString(cell) {    " & _
                              "  if(typeof cell === 'string' || cell instanceof String)    {" & _
                              "    return '""' + cell +'""';;} else {return cell.toString();} }"
        
        Debug.Assert oScriptEngine.Run("quoteString", 8) = "8"
        Debug.Assert oScriptEngine.Run("quoteString", "bar") = """bar"""
        
        oScriptEngine.AddCode _
            "function JsonArrayToXlArray(array) { " & _
            "  var xlArray=''; " & _
            "  for (var i=0; i0) {xlArray=xlArray+';';} " & _
            "    for (var j=0;j0) {row=row+',';} " & _
            "      row=row + quoteString(array[i][j]); " & _
            "    } " & _
            "    xlArray=xlArray+row; " & _
            "  } " & _
            "  xlArray='{' + xlArray + '}'; " & _
            "return xlArray; }"
    End If
    
    Dim objJson2dArray As Object
    Set objJson2dArray = oScriptEngine.Eval("(" + sJson2dArray + ")")
    
    Dim sXlArray As String
    sXlArray = oScriptEngine.Run("JsonArrayToXlArray", objJson2dArray)
    
    JsonArrayToXlArray = Application.Evaluate(sXlArray)
End Function

If you want to see the Javascript better ...

var array=[['foo',2],[3,4]];
var xlArray="";

xlArray=JsonArrayToXlArray(array);
alert(xlArray);

function JsonArrayToXlArray(array) {
var xlArray=''; 
for (var i=0; i0) {xlArray=xlArray+';';}
    for (var j=0;j0) {row=row+',';}   
        row=row + quoteString(array[i][j]);    
    }
    xlArray=xlArray+row;
} 
xlArray='{' + xlArray + '}';
return xlArray;
}

function quoteString(cell) {
   if(typeof cell === 'string' || cell instanceof String)
   {return '"' + cell +'"';;}
   else
   {return cell.toString();}
}

Make VBA Array Literals plus some variables

So just browsing a Python tutorial currently and it is impressive how newer languages such as Python and Javascript have the ability to create tuples and data structures on the fly. VBA has an array literal syntax which can accept both numbers and strings but supplying a variable into one of the locations breaks. So I've decided to write some code and might as well share

Sub DemoMakeArrayLiteral()
    Dim v
    v = [{1,2;3,4}]
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = 2
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = 4
    
    Dim v2
    v2 = [{1,2;3,"foo"}] '* with a string literal
    Debug.Assert v2(1, 1) = 1
    Debug.Assert v2(1, 2) = 2
    Debug.Assert v2(2, 1) = 3
    Debug.Assert v2(2, 2) = "foo"
    
    Dim a
    a = "bar"
    Dim v3
    v3 = [{1,2;3,a}] '* WRONG WAY for a variable, contaminates whole array
    Debug.Assert IsError(v3)

    Dim v4
    v4 = MakeArrayLiteral([{1,2;3,"$0"}], a) '* RIGHT WAY for a variable
    Debug.Assert v4(1, 1) = 1
    Debug.Assert v4(1, 2) = 2
    Debug.Assert v4(2, 1) = 3
    Debug.Assert v4(2, 2) = "bar"


End Sub





Private Function MakeArrayLiteral(ByVal vSeed As Variant, ParamArray args() As Variant) As Variant
    
    If IsError(vSeed) Then GoTo SingleExit
    
    Dim lArgCount As Long
    lArgCount = UBound(args) - LBound(args) + 1
    
    If lArgCount > 0 Then
        
        Dim dicReplacements As Scripting.Dictionary
        
        Dim dicGetDimsAndBounds As Scripting.Dictionary
        Set dicGetDimsAndBounds = GetDimsAndBounds(vSeed)
        
        Dim lDollarNum As Long
        lDollarNum = -1
        
        If dicGetDimsAndBounds.Count = 0 Then
            lDollarNum = GetDollarNum(vSeed)
            If lDollarNum <> -1 And lDollarNum <= lArgCount - 1 Then
                vSeed = Replace(vSeed, "$" & lDollarNum, args(lDollarNum))
            End If
        ElseIf dicGetDimsAndBounds.Count = 1 Then
        
            'Stop
            Dim vBounds As Variant
            vBounds = dicGetDimsAndBounds.Item(1)
            Dim lIndex As Long
            For lIndex = vBounds(0) To vBounds(1)
                lDollarNum = GetDollarNum(vSeed(lIndex))
                If lDollarNum <> -1 And lDollarNum <= lArgCount - 1 Then
                    vSeed(lIndex) = Replace(vSeed(lIndex), "$" & lDollarNum, args(lDollarNum))
                End If
            Next
        
        ElseIf dicGetDimsAndBounds.Count = 2 Then
            Dim vYBounds As Variant
            vYBounds = dicGetDimsAndBounds.Item(1)
        
            Dim vXBounds As Variant
            vXBounds = dicGetDimsAndBounds.Item(2)
        
            Dim lXIndex As Long
            For lXIndex = vXBounds(0) To vXBounds(1)
                
                Dim lYIndex As Long
                For lYIndex = vYBounds(0) To vYBounds(1)
                
                    lDollarNum = GetDollarNum(vSeed(lYIndex, lXIndex))
                    If lDollarNum <> -1 And lDollarNum <= lArgCount - 1 Then
                        vSeed(lYIndex, lXIndex) = Replace(vSeed(lYIndex, lXIndex), "$" & lDollarNum, args(lDollarNum))
                    End If
        
                Next
            Next
        
        ElseIf dicGetDimsAndBounds.Count > 2 Then
            Err.Raise vbObjectError, , "#Dimensions greater than 2 not yet supported!"
        End If
        
    
    
    
    
    End If
SingleExit:
    MakeArrayLiteral = vSeed
End Function


Private Function GetDims(ByRef v) As Long
    On Error GoTo BadDimension
    GetDims = 0
    Dim lDim As Long
    For lDim = 1 To 100
        Dim vTest As Variant
        vTest = LBound(v, lDim)
        GetDims = lDim
    Next lDim
SingleExit:
    Exit Function
BadDimension:
    GoTo SingleExit
End Function


Private Function GetDimsAndBounds(v As Variant) As Scripting.Dictionary

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

End Function

Private Function GetDollarNum(ByRef v) As Long

    Debug.Assert Not IsError(v)


    GetDollarNum = -1
    
    

    Static reDollarNum As VBScript_RegExp_55.RegExp
    If reDollarNum Is Nothing Then
        Set reDollarNum = New VBScript_RegExp_55.RegExp
        reDollarNum.Pattern = "\$(\d+)"
    End If

    If reDollarNum.Test(v) Then
        Dim oMatchCol As VBScript_RegExp_55.MatchCollection
        Set oMatchCol = reDollarNum.Execute(v)
        If oMatchCol.Count = 1 Then
            Dim oMatch As VBScript_RegExp_55.Match
            Set oMatch = oMatchCol.Item(0)
            If oMatch.SubMatches.Count = 1 Then
                GetDollarNum = CLng(oMatch.SubMatches(0))
            End If
        End If
    End If

End Function

'* UNIT TESTS
Private Sub TestGetDollarNum()

    Debug.Assert GetDollarNum("$456") = 456
    Debug.Assert GetDollarNum("$45.6") = 45
    Debug.Assert GetDollarNum("$6") = 6
    Debug.Assert GetDollarNum("$77") = 77
    Debug.Assert GetDollarNum("$") = -1

End Sub

Private Sub TestGetDims()
    Dim scalar As Variant
    scalar = 1
    Debug.Assert GetDims(scalar) = 0

    Dim v1
    v1 = [{1,2}]
    Debug.Assert GetDims(v1) = 1

    Dim v
    v = [{1,2;3,4}]
    Debug.Assert GetDims(v) = 2

    Dim z
    z = [{"1","2";"3","4"}]
    Debug.Assert GetDims(z) = 2
End Sub

Sub TestMakeArrayLiteral()
    Dim v As Variant
    v = MakeArrayLiteral([{1,2;3,4}])
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = 2
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = 4
    
End Sub


Sub TestMakeArrayLiteral0()
    Dim v As Variant
    v = MakeArrayLiteral("$0", "FOO")
    Debug.Assert v = "FOO"
    
End Sub

Sub TestMakeArrayLiteral1()
    Dim v As Variant
    v = MakeArrayLiteral([{1,2,"$0"}], "FOO")
    Debug.Assert v(3) = "FOO"
    
End Sub

Sub TestMakeArrayLiteral2()
    Dim v As Variant
    v = MakeArrayLiteral([{1,2;3,"$0"}], "FOO")
    Debug.Assert v(2, 2) = "FOO"
    
End Sub

Sub TestMakeArrayLiteral3()
    Dim v As Variant
    v = MakeArrayLiteral([{1,"$1";3,"$0"}], "FOO", "BAR")
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = "BAR"
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = "FOO"
    
End Sub

Sub TestMakeArrayLiteral4()
    Dim v As Variant
    v = MakeArrayLiteral([{1,"$1fly";3,"$0"}], "FOO", "BAR")
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = "BARfly"
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = "FOO"
    
End Sub

ActiveDirectory with VBA Part 6 - Extending the AD LDS Schema

So although following the instructions in the Technet tutorials and followed in parts 1, 2 and 4 is fine it seems AD LDS is extensible and the given schema in those tutorials is limited. If you want an extended set of object classes then you need to Extened the AD LDS Schema but there is a typo in the given command line which is corrected here

Once the schema has been extended then the New Object dialog box should show a far greater list of object that you can create.

ActiveDirectory with VBA Part 5 - Querying LDAP with ADO

So in addition to using the GetObject("LDAP//... syntax one can also query LDAP Active Directory using ActiveX Data Objects (ADO). You will need to use the Microsoft OLE DB Provider for Microsoft Active Directory Service.

I can give some VBA which queries the AD LDS instance created in part 1, part 2 and part 4 of this series. If you run the following code you should get the table of results shown below.

Sub QueryingLDAPWithADO()
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    cn.ConnectionString = "Provider=ADSDSOObject" '* ref https://msdn.microsoft.com/en-us/library/aa746471(v=vs.85).aspx
    cn.Open

    Sheet1.Cells.ClearContents
    Sheet1.Range("A1:F1").Font.Italic = False
    Sheet1.Range("A1:F1").Font.Bold = True
    Sheet1.Range("A2:F2").Font.Italic = True


    Dim cmdSQL_Dialect As ADODB.Command
    Set cmdSQL_Dialect = New ADODB.Command
    cmdSQL_Dialect.CommandText = "Select nAME,distinguishedName FROM 'LDAP://localhost:389/o=Microsoft,c=US' WHERE objectClass='*'"

    Set cmdSQL_Dialect.ActiveConnection = cn
    
    Dim rsSQL_Dialect As ADODB.Recordset
    Set rsSQL_Dialect = cmdSQL_Dialect.Execute
    Sheet1.Cells(1, 1).Value = "SQL Dialect query"
    Sheet1.Cells(2, 2).Value = "Name"    '* seems the fields are in reversed order, perhaps alphabetical?
    Sheet1.Cells(2, 1).Value = "DistinguishedName"
    Sheet1.Cells(3, 1).CopyFromRecordset rsSQL_Dialect

    Dim cmdLDAP_Dialect As ADODB.Command
    Set cmdLDAP_Dialect = New ADODB.Command
    cmdLDAP_Dialect.CommandText = ";(objectClass=*);CN; subtree"
    
    Set cmdLDAP_Dialect.ActiveConnection = cn
    
    Dim rsLDAP_Dialect As ADODB.Recordset
    Set rsLDAP_Dialect = cmdLDAP_Dialect.Execute
    
    Sheet1.Cells(1, 4).Value = "LDAP Dialect query"
    Sheet1.Cells(2, 4).Value = "CN"
    Sheet1.Cells(3, 4).CopyFromRecordset rsLDAP_Dialect
End Sub

ActiveDirectory with VBA Part 4 - ADSI Edit

So in Part 1 I installed Active Directory Lightweight Directory Services (AD LDS) and in Part 2 worked through a Technet tutorial to create an AD LDS instance, also in Part 3. I showed how to uninstall an instance to wipe the slate clean. I gave some code that connected to the AD LDS instance a the bottom of Part 2.

Next I proceed with the subsequent Technet tutorial as it creates users and groups with some Active Directory administrative tools.

So launching ADSI Edit you get a MMC looking welcome screen with no connections...

Following the tutorial for connecting the finished dialog box looks like this...

Once connected the left explorer pane should have a new AD LDS Demo icon which can be double-clicked for expansion...

Double clicking on 'O=Microsoft,c' shows the application directory partition...

Carrying onto the next Technet tutorial in series about creating users and groups. After this tutorial some new objects have been created reflected in this screenshot.

When finished the following VBA code should be able to reach, query and find each object mentioned in the tutorial. This will help setup test data for more involved user and group logic.

Option Explicit

Sub Test()

    Dim oDirectoryService As Object
    Set oDirectoryService = _
        GetObject("LDAP://localhost:389/o=Microsoft,c=US")
    Debug.Assert TypeName(oDirectoryService) = "Object"

    Dim oOU_AD_LDS_Users As Object
    Set oOU_AD_LDS_Users = GetObject( _
        "LDAP://localhost:389/OU=AD LDS Users,o=Microsoft,c=US")
    Debug.Assert TypeName(oOU_AD_LDS_Users) = "Object"

    Dim oGroup_AD_LDS_Testers As Object
    Set oGroup_AD_LDS_Testers = GetObject( _
        "LDAP://localhost:389/CN=AD LDS Testers,OU=AD LDS Users,o=Microsoft,c=US")
    Debug.Assert TypeName(oGroup_AD_LDS_Testers) = "Object"

    Dim oUser_MaryNorth As Object
    Set oUser_MaryNorth = GetObject( _
        "LDAP://localhost:389/CN=Mary North,OU=AD LDS Users,o=Microsoft,c=US")
    Debug.Assert TypeName(oUser_MaryNorth) = "Object"


End Sub

ActiveDirectory with VBA Part 3 - Technet AD LDS Deleting an Instance

So I have been following the Technet tutorial Practice Working with AD LDS Instances and it assumes that you have a fresh install or the defaults in the wizard will be different. If you have been through the steps you might want to wipe the slate clean. In this part I show how to delete an Active Directory Lightweight Directory Services (AD LDS) instance.

In the Control Panel search box type "uninstall" this will yield search results including for Uninstall a program under the header of Program and Features

Clicking on Uninstall a program yields a list of software which is uninstallable.

Double click and follow a few 'are you sure' type messages.

ActiveDirectory with VBA Part 2 - Technet AD LDS Sample Instance

So following on from installing Active Directory Lightweight Directory Services (AD LDS) in Part 1 here I follow the Technet tutorial Practice Working with AD LDS Instances and I supply the screenshots as I go.

So we run the Active Directory Lightweight Directory Services Setup Wizard and I did do this by searching for it with the Windows 8 metro search box, after allowing permission I get the following welcome box

Clicking Next I get to next box and choose 'A unique instance'

For the instance name I accept the default as I am following the tutorial. If you are doing these twice then instance1 is taken, you may want to skip to Part 3 where I show how to delete an instance.

For the port numbers again things will be different if you have already run these steps once and already have an instance because each instance must listen on a different port. See Part 3 for how to delete an instance.

Because we're opening ports then you may get a firewall warning message like this so I select private networks only...

And again I am following the tutorial so I follow instructions, create an application directory partition and give the Partition name as in the tutorial as 'o=Microsoft,c=US'.

Next we accept the default file locations

Next use Nework service account as per tutorial

Then you will get a replication not available type warning box, click Yes to continue.

Then you get the AD LDS Administrators box, note I have airbrushed my details from this slide. Click the default value of Currently logged on user.

On the Importing LDIF Files. Select the following MS-InetOrgPerson.ldf, MS-User.ldf, MS-UserProxy.ldf, MS-UserProxyFull.ldf, MS-ADLDS-DisplaySpecifiers.ldf. NOT ALL OF THESE ARE IMMEDIATELY VISIBLE, YOU NEED TO SCROLL

Then you get a confirmation screen...

Then it does some work...

Then you get some success splash screen.

Now you can write some code to connect to this new AD LDS instance. This should work if you went wrong you'll need to use Part 3 to delete instance and try again

Option Explicit

Sub Test()

    Dim oDirectoryService As Object
    Set oDirectoryService = GetObject("LDAP://localhost:389/o=Microsoft,c=US")
    Debug.Assert TypeName(oDirectoryService) = "Object"

End Sub

ActiveDirectory with VBA Part 1 - Installing AD LDS

So in various roles I've written code in production to query a corporate active directory to query for users and check group membership to drive permission logic. In those times, I always had a corporate instance of Windows Server to program against. What happens if you don't have access to a Windows Server using a ordinary desktop edition of Windows? I am using Windows 8.1 Professional Edition.

It might be tempting to download ApacheDS which is free but that cannot be accesed using VBA's GetObject("LDAP://CN=BillGates,DC=microsoft,DC=com").

You will need to use something like a development edition of Active Directory. Fortunately, a lightweight edition does exists, here is an overview of Active Directory Lightweight Directory Services (AD LDS) and here is a quote highlighting the development use case...

Providing a development environment for AD DS and AD LDS

Because AD LDS uses the same programming model and provides virtually the same administration experience as AD DS, it can be a good fit for developers who are staging and testing various Active Directory-integrated applications. For example, if an application under development requires a different schema from the current server operating system AD DS, the application developer can use AD LDS to provide the application with a tailored schema that works for business needs, data requirements, and workflow processes, without altering the configuration of the corporate Active Directory deployment. Developers can work with an AD LDS instance without the need for a complicated setup and later move the application to AD DS. Developers may want a directory that they can easily program to without requirements for extensive setup or hardware support during the development process. This can be achieved through AD LDS as it can easily be installed and uninstalled on any Windows Server 2008 computer. This allows rapid restoration to a clean state during the application prototyping and development process.

Luckily Active Directory Lightweight Directory Services (AD LDS) is an optional component if you are using Windows 8.1 (and hopefully other desktop editions of Windows), from the Metro interface search box type "Windows features" and then select "Turn Windows features on or off" which should be top hit. Then you should see the following dialog box where you can check "Active Directory Lightweight Directory Services"

Once installed, I followed a Technet tutorial about creating an AD LDS Instance and in Part 2. I'll show you my screenshots as I went through the steps.