Excellerando

Demising VBA: the caret and stick approach

2011-08-30T19:46:00.008+01:00

I haven't been posting much in the last year, because the work I'm doing is under contract and I don't own the source code... So I can't publish it here. I can't complain: everyone's tightened up the IP and disclosure rules in their contracts and workng quietly beats hell out of not working.

So, in the absence of any actual content from me, here's a little gem from Tushar Mehta, on VBA in Office 2010:

To support this new data type, Microsoft also introduced the CLngLng function, the VarType constant vbLongLong, and the DefType statement DefLngLng. The type declaration character is ^. This can cause problems while typing VBA statements that use the exponentiation operator, which is also ^.

Feel free to read the details... And remember to insert a space before indicating an exponent in your calculations.

I wonder what else is out there, waiting to be discovered. I wonder, also, whether any other financial institution has made the transition to Office 2010, outside of a few 'early adopters' who amuse and entertain their IT staff with their ingenuity. We've only got about 50,000 regular users, worldwide - regular as in 'I use it every day in a critical part of my job', and probably twice that number of occasionals, so we're talking about a fair chunk of revenue for Microsoft here, and you'd think they'd make it easy for us to migrate.

Actually, you know Microsoft: you know damn' well they've made it difficult.

Everything we've done in terms of macros and reports, all the way up to add-ins and fully-developed applications, will need some testing - that's standard for all Office upgrades, even service patches - and we test the complex ones quite thoroughly. You'd think there might be tools, and scripts, and maybe even checklists and case studies. But no: Microsoft is unlike any other software vendor. And we start this job *knowing* that everything we've build that uses the application menubar is broken, by design, by Microsoft's insistence on imposing the new 'Ribbon Bar' with no concession whatsoever to supporting backward compatibility... I predict thet we'll be using Office 2003 well into 2012; and that there are major companies as big as us, or bigger, who'll be using it in 2014.

Ultimately, Microsoft will kill off VBA and this is just another nail in the coffin; they are, if you will, putting the caret before the hearse.

VLookup() with fuzzy-matching to get a 'closest match' result

2010-03-01T21:14:00.010Z

Ever had to look up a name or an address in a list that doesn't quite match, so the standard Excel 'VLookup()' and 'Match()' functions don't help you?

Here's the solution:

The answer is 'Fuzzy Matching', a process of applying rules and picking out a 'best fit'. In the case of text - words, addresses, alphanumeric codes like ISIN identifiers for shares, bonds and other financial instruments - the best approach is the Levenshtein Edit Distance algorithm, a measure of how many characters were changed or moved to get from one text to another; but I've gone for a simplified approach that adds up how much of text A is made up of recognisable fragments of text B.

It works surprisingly well, but there are some limitations. There's a more detailed discussion of this in the preceding post: feel free to offer some suggestions and comments there: what you're reading here is the application of these abstract principles to spreadsheets. Click on the image: it'll show you how the function is used.

What's missing is a version of Match() (you can code that up for yourselves), and a dedicated 'FuzzyVLookupAddress()' function, tweaked to deal with the peculiar things that we do to postal addresses to make them extraordinarily difficult for computers (and spreadsheets!) to read. Instead, I've provided a crude 'NormaliseAddress' function, which standardises all those troublesome Aves, Avenues, Streets, Saints and St.'s. Apply it to the addresses in your list (and to the search term you're trying to look up) and let me know how you get on.

Enough witter: the code's below. It's been tested for cut-and-paste out of Blogger, but there's always a health warning: Blogger will munge the line breaks, and so will whatever you're using to view this post, especially if it's an RSS feed.

Option Explicit

Public Function FuzzyVLookup(Lookup_Value As String, _
                             Table_Array As Variant, _
                             Optional Col_Index_Num As Integer = 1, _
                             Optional Compare As VbCompareMethod = vbTextCompare _
                            ) As Variant

' Find the best match for a given string in column 1 of an array of data obtained from an Excel range
' This is functionally similar to VLookup, but it returns the best match, not the first exact match
' This function is not case-sensitive, unless you specify 'Compare' as 0 or vbBinaryCompare

' If your data quality is poor, you are advised to display the retrieved index value from column 1
' and use the FuzzyMatchScore() function on this index value to reveal the fuzzy-matching 'score' and
' discard all results below a threshold value. Feel free to code up a 'threshold' parameter!

' If you are looking up names and addresses, use the NormaliseAddress() function on your search term and
' searched population to standardise abbreviations and word-order conventions used in British addresses.

' THIS CODE IS IN THE PUBLIC DOMAIN

Application.Volatile False

Dim dblBestMatch As Double

Dim iRowBest    As Integer
Dim dblMatch    As Double
Dim iRow        As Integer
Dim strTest     As String
Dim strInput    As String

Dim iStartCol   As Integer
Dim iEndCol     As Integer
Dim iOffset     As Integer

If InStr(TypeName(Table_Array), "(") + InStr(1, TypeName(Table_Array), "Range", vbTextCompare) < 1 Then
     'Table_Array is not an array
     FuzzyVLookup = "#VALUE"
    Exit Function
End If

If InStr(1, TypeName(Table_Array), "Range", vbTextCompare) > 0 Then
    Table_Array = Table_Array.Value
End If

' If you get a subscript-out-of-bounds error here, you're using a vector instead
' of the 2-dimensional array that is the default 'Value' property of an Excel range.

iStartCol = LBound(Table_Array, 2)
iEndCol = UBound(Table_Array, 2)
iOffset = 1 - iStartCol

Col_Index_Num = Col_Index_Num - iOffset

If Col_Index_Num > iEndCol Or Col_Index_Num < iStartCol Then
     'Out-of-bounds
     FuzzyVLookup = "#VALUE"
    Exit Function
End If

    strInput = UCase(Lookup_Value)

    iRowBest = -1
    dblBestMatch = 0

    For iRow = LBound(Table_Array, 1) To UBound(Table_Array, 1)

        strTest = ""
        strTest = Table_Array(iRow, iStartCol)

        dblMatch = 0
        dblMatch = FuzzyMatchScore(strInput, strTest, Compare)

        If dblMatch = 1 Then ' Bail out on finding an exact match
            iRowBest = iRow
            Exit For
        End If

        If dblMatch > dblBestMatch Then
            dblBestMatch = dblMatch
            iRowBest = iRow
        End If

    Next iRow

    If iRowBest = -1 Then
        FuzzyVLookup = "#NO MATCH"
        Exit Function
    End If

    FuzzyVLookup = Table_Array(iRowBest, Col_Index_Num)

End Function

Public Function FuzzyHLookup(Lookup_Value As String, _
                             Table_Array As Variant, _
                             Optional Row_Index_Num As Integer = 1, _
                             Optional Compare As VbCompareMethod = vbTextCompare)

' Find the best match for a given string in Row 1 of an array of data obtained from an Excel range
' This is functionally similar to HLookup, but it returns the best match, not the first exact match
' This function is not case-sensitive, unless you specify 'Compare' as vbTextBinary.

' If your data quality is poor, you are advised to display the retrieved index value from row 1
' and use the FuzzyMatchScore() function on this index value to reveal the fuzzy-matching 'score' and
' discard all results below a threshold value. Feel free to code up a 'threshold' parameter!

' If you are looking up names and addresses, use the NormaliseAddress() function on your search term and
' searched population to standardise abbreviations and word-order conventions used in British addresses.

' THIS CODE IS IN THE PUBLIC DOMAIN

Application.Volatile False

Dim dblBestMatch As Double

Dim iColBest    As Integer
Dim dblMatch    As Double
Dim iCol        As Integer
Dim strTest     As String
Dim strInput    As String

Dim iStartRow   As Integer
Dim iEndRow     As Integer
Dim iOffset     As Integer

If InStr(TypeName(Table_Array), "(") + InStr(1, TypeName(Table_Array), "Range", vbTextCompare) < 1 Then
     'Table_Array is not an array
     FuzzyHLookup = "#VALUE"
    Exit Function
End If

If InStr(1, TypeName(Table_Array), "Range", vbTextCompare) > 0 Then
    Table_Array = Table_Array.Value
End If

' If you get a subscript-out-of-bounds error here, you're using a vector instead
' of the 2-dimensional array that is the default 'Value' property of an Excel range.

iStartRow = LBound(Table_Array, 1)
iEndRow = UBound(Table_Array, 1)
iOffset = 1 - iStartRow

Row_Index_Num = Row_Index_Num - iOffset

If Row_Index_Num > iEndRow Or Row_Index_Num < iStartRow Then
     'Out-of-bounds
     FuzzyHLookup = "#VALUE"
    Exit Function
End If

    strInput = UCase(Lookup_Value)

    iColBest = -1
    dblBestMatch = 0

    For iCol = LBound(Table_Array, 2) To UBound(Table_Array, 2)

        strTest = ""
        strTest = Table_Array(iStartRow, iCol)

        dblMatch = 0
        dblMatch = FuzzyMatchScore(strInput, strTest, Compare)

        If dblMatch = 1 Then ' Bail out on finding an exact match
            iColBest = iCol
            Exit For
        End If

        If dblMatch > dblBestMatch Then
            dblBestMatch = dblMatch
            iColBest = iCol
        End If

    Next iCol

    If iColBest = -1 Then
        FuzzyHLookup = "#NO MATCH"
        Exit Function
    End If

    FuzzyHLookup = Table_Array(Row_Index_Num, iColBest)

End Function

Public Function FuzzyMatchScore(ByVal str1 As String, _
                                ByVal str2 As String, _
                                Optional Compare As VbCompareMethod = vbTextCompare _
                                ) As Double

' Returns an estimate of how closely word 1 matches word 2: this is best displayed as a percentage
' This is calculated as the fraction of the longer string that is made up of recognisable fragments of the shorter string
' There is no support for wildcards and regular expressions. Case-sensitivity is determined by the 'compare' parameter

' THIS CODE IS IN THE PUBLIC DOMAIN

Application.Volatile False

Dim maxLen As Integer
Dim minLen As Integer

    If str1 = str2 Then
        FuzzyMatchScore = 1#
        Exit Function
    End If

    If Len(str1) > Len(str2) Then
        maxLen = Len(str1)
        minLen = Len(str2)
    Else
        maxLen = Len(str2)
        minLen = Len(str1)
    End If

    If Len(str1) = 0 Or Len(str2) = 0 Then
        FuzzyMatchScore = 0#
    Else

        FuzzyMatchScore = 0#
        FuzzyMatchScore = SumOfCommonStrings(str1, str2, Compare) / maxLen

    End If

End Function

Public Function SumOfCommonStrings( _
                            ByVal s1 As String, _
                            ByVal s2 As String, _
                            Optional Compare As VBA.VbCompareMethod = vbTextCompare, _
                            Optional iScore As Integer = 0 _
                                ) As Integer

Application.Volatile False

' N.Heffernan 06 June 2006 (somewhere over Newfoundland)
' THIS CODE IS IN THE PUBLIC DOMAIN

' Function to measure how much of String 1 is made up of substrings found in String 2

' This function uses a modified Longest Common String algorithm.
' Simple LCS algorithms are unduly sensitive to single-letter
' deletions/changes near the midpoint of the test words, eg:
' Wednesday is obviously closer to WedXesday on an edit-distance
' basis than it is to WednesXXX. So it would be better to score
' the 'Wed' as well as the 'esday' and add up the total matched

' Watch out for strings of differing lengths:
'
'    SumOfCommonStrings("Wednesday", "WednesXXXday")
'
' This scores the same as:
'
'     SumOfCommonStrings("Wednesday", "Wednesday")
'
' So make sure the calling function uses the length of the longest
' string when calculating the degree of similarity from this score.

' This is coded for clarity, not for performance.

Dim arr() As Integer    ' Scoring matrix
Dim n As Integer        ' length of s1
Dim m As Integer        ' length of s2
Dim i As Integer        ' start position in s1
Dim j As Integer        ' start position in s2
Dim subs1 As String     ' a substring of s1
Dim len1 As Integer     ' length of subs1

Dim sBefore1            ' documented in the code
Dim sBefore2
Dim sAfter1
Dim sAfter2

Dim s3 As String

SumOfCommonStrings = iScore

n = Len(s1)
m = Len(s2)

If s1 = s2 Then
    SumOfCommonStrings = n
    Exit Function
End If

If n = 0 Or m = 0 Then
    Exit Function
End If

's1 should always be the shorter of the two strings:
If n > m Then
    s3 = s2
    s2 = s1
    s1 = s3
    n = Len(s1)
    m = Len(s2)
End If

n = Len(s1)
m = Len(s2)

' Special case: s1 is n exact substring of s2
If InStr(1, s2, s1, Compare) Then
    SumOfCommonStrings = n
    Exit Function
End If

For len1 = n To 1 Step -1

    For i = 1 To n - len1 + 1

        subs1 = Mid(s1, i, len1)
        j = 0
        j = InStr(1, s2, subs1, Compare)

        If j > 0 Then

            ' We've found a matching substring...
            iScore = iScore + len1

          ' Now clip out this substring from s1 and s2...
          ' And search the fragments before and after this excision:


            If i > 1 And j > 1 Then
                sBefore1 = left(s1, i - 1)
                sBefore2 = left(s2, j - 1)
                iScore = SumOfCommonStrings(sBefore1, _
                                            sBefore2, _
                                            Compare, _
                                            iScore)
            End If


            If i + len1 < n And j + len1 < m Then
                sAfter1 = right(s1, n + 1 - i - len1)
                sAfter2 = right(s2, m + 1 - j - len1)
                iScore = SumOfCommonStrings(sAfter1, _
                                            sAfter2, _
                                            Compare, _
                                            iScore)
            End If


            SumOfCommonStrings = iScore
            Exit Function

        End If

    Next

Next

End Function

Private Function Minimum(ByVal a As Integer, _
                         ByVal b As Integer, _
                         ByVal c As Integer) As Integer
Dim min As Integer

  min = a

  If b < min Then
        min = b
  End If

  If c < min Then
        min = c
  End If

  Minimum = min

End Function

Public Function NormaliseAddress(ByVal strAddress As String) As String
Application.Volatile False
' This function is intended to remove or standardise common phrases
' and abbreviations used in British postal addresses, allowing the use
' of string-comparison algorithms in lists of names and addresses.

' Developers in other countries should review the word list used here,
' as conventions probably differ in your local language or dialect.

strAddress = " " & UCase(strAddress) & " "

strAddress = Substitute(strAddress, ",", " ")
strAddress = Substitute(strAddress, ".", " ")
strAddress = Substitute(strAddress, "-", " ")
strAddress = Substitute(strAddress, vbCrLf, " ")
strAddress = Substitute(strAddress, " BLVD ", " BOULEVARD ")
strAddress = Substitute(strAddress, " BVD ", " BOULEVARD ")
strAddress = Substitute(strAddress, " AV ", " AVENUE ")
strAddress = Substitute(strAddress, " AVE ", " AVENUE ")
strAddress = Substitute(strAddress, " RD ", " ROAD ")
strAddress = Substitute(strAddress, " WY ", " WAY ")
strAddress = Substitute(strAddress, " EST ", " ESTATE ")
strAddress = Substitute(strAddress, " PL ", " PLACE ")
strAddress = Substitute(strAddress, " PK ", " PARK ")
strAddress = Substitute(strAddress, " HSE ", " HOUSE ")
strAddress = Substitute(strAddress, " H0 ", " HOUSE ")
strAddress = Substitute(strAddress, " GDNS ", " GARDENS ")

strAddress = Substitute(strAddress, "&", "AND")
strAddress = Substitute(strAddress, " LIMITED ", " LTD ")
strAddress = Substitute(strAddress, " COMPANY ", " CO ")
strAddress = Substitute(strAddress, " CORPORATION ", " CORP ")
strAddress = Substitute(strAddress, " T/A ", " TA ")
strAddress = Substitute(strAddress, " TRADING AS ", " TA ")

' Common personal titles: these are often applied inconsistently or
' omitted, and must therefore be removed. Specific applications may
' require additional titles and their abbreviations - military rank,
' academic titles and degrees, courtesy titles of the aristocracy,
' knighthoods and honours (particularly for lists of civil servants)

strAddress = Substitute(strAddress, " ESQ ", " ")
strAddress = Substitute(strAddress, " MR ", " ")
strAddress = Substitute(strAddress, " MRS ", " ")
strAddress = Substitute(strAddress, " MISS ", " ")
strAddress = Substitute(strAddress, " MS ", " ")
strAddress = Substitute(strAddress, " MESSRS ", " ")
strAddress = Substitute(strAddress, " SIR ", " ")
strAddress = Substitute(strAddress, " OF ", " ")
strAddress = Substitute(strAddress, " DR ", " ")
strAddress = Substitute(strAddress, " OR ", " ")
strAddress = Substitute(strAddress, " IN ", " ")
strAddress = Substitute(strAddress, " THE ", " ")
strAddress = Substitute(strAddress, " REVEREND ", " REV ")
strAddress = Substitute(strAddress, " REVERENT ", " REV ")
strAddress = Substitute(strAddress, " HONOURABLE ", " HON ")
strAddress = Substitute(strAddress, " BROS ", " BROTHERS ")
strAddress = Substitute(strAddress, " ASSOC ", " ASSOCIATION ")
strAddress = Substitute(strAddress, " ASSN ", " ASSOCIATION ")

' Standardising 'St.', 'St', and 'Street'. Note that there are over 40 English
' towns and place names that contain or consist entirely of the word 'Street'.
' In addition, 'St' is a common abbreviation for 'Saint' in addresses.

' I have never seen a list of addresses where 'Street' and 'St' were used in a
' consistent way, and the only workable solution is to delete them all:

strAddress = Substitute(strAddress, " STREET ", " ")
strAddress = Substitute(strAddress, " ST ", " ")
strAddress = Substitute(strAddress, " STR ", " ")

Do While InStr(strAddress, "  ") > 0
    strAddress = Substitute(strAddress, "  ", " ")
Loop

strAddress = Trim(strAddress)

NormaliseAddress = strAddress

End Function

Public Function StripChars(myString As String, ParamArray Exceptions()) As String

' Strip out all non-alphanumeric characters from a string in a single pass
' Exceptions parameters allow you to retain specific characters (eg: spaces)

' THIS CODE IS IN THE PUBLIC DOMAIN

Application.Volatile False

Dim i As Integer
Dim iLen As Integer
Dim chrA As String * 1
Dim intA As Integer
Dim j As Integer
Dim iStart As Integer
Dim iEnd As Integer

If Not IsEmpty(Exceptions()) Then
    iStart = LBound(Exceptions)
    iEnd = UBound(Exceptions)
End If

iLen = Len(myString)

For i = 1 To iLen
    chrA = Mid(myString, i, 1)
    intA = Asc(chrA)
    Select Case intA
    Case 48 To 57, 65 To 90, 97 To 122
        StripChars = StripChars & chrA
    Case Else
        If Not IsEmpty(Exceptions()) Then
            For j = iStart To iEnd
                If chrA = Exceptions(j) Then
                    StripChars = StripChars & chrA
                    Exit For ' j
                End If
            Next j
        End If
    End Select
Next i

End Function

Private Function Substitute(ByVal Text As String, _
                            ByVal Old_Text As String, _
                            ByVal New_Text As String, _
                            Optional Instance As Long = 0, _
                            Optional Compare As VbCompareMethod = vbTextCompare _
                            ) As String

' Replace all instances (or the nth instance ) of 'Old' text with 'New'
' Unlike VB.Mid$ this method is not sensitive to length and can replace ALL instances
' This is not exposed as a Public function because there is an Excel Worksheet function
' called Substitute(). However, Workheet Functions have length constraints.

' THIS CODE IS IN THE PUBLIC DOMAIN

Dim iStart As Long
Dim iEnd As Long
Dim iLen As Long
Dim iInstance As Long
Dim strOut As String

iLen = Len(Old_Text)

If iLen = 0 Then
    Substitute = Text
    Exit Function
End If

iEnd = 0
iStart = 1

iEnd = InStr(iStart, Text, Old_Text, Compare)

If iEnd = 0 Then
    Substitute = Text
    Exit Function
End If

strOut = ""

Do Until iEnd = 0

    strOut = strOut & Mid$(Text, iStart, iEnd - iStart)
    iInstance = iInstance + 1

    If Instance = 0 Or Instance = iInstance Then
        strOut = strOut & New_Text
    Else
        strOut = strOut & Mid$(Text, iEnd, Len(Old_Text))
    End If

    iStart = iEnd + iLen
    iEnd = InStr(iStart, Text, Old_Text, Compare)

Loop

iLen = Len(Text)
strOut = strOut & Mid$(Text, iStart, iLen - iEnd)

Substitute = strOut

End Function

This is something I coded up on an obscure personal blog a couple of years ago: I get one or two enquiries about it every year (mostly appreciative) so I've tidied it up, tested it more thoroughly, and released it into the wild on Excellerando.

String-Comparison in VBA: a modified Longest-Common-String approach

2010-02-27T11:07:00.003Z

Summary:

I discuss the use of a sum-of-longest-common-strings algorithm to measure the degree of difference between strings. This is efficient in VBA, and can be used as a the basis as a closest-match alternative to VLookup and Match.

The Details...

A couple of years ago, I looked at writing a fuzzy-matching version of VLookup, to return the closest match to a search string rather than the #NA() that comes back from the standard Excel function. I posted it in an obscure personal blog, and forgot about it. But I'll be posting it here, shortly, and this post is the introduction to it, with an explanation of the principles and the core VBA function that drives the whole thing.

Originally,I looked at using a Levenshtein 'Edit Distance' algorithm to compare and measure the degree of difference between strings. (Thanks are due to the inestimable Mr. Crowley for pointing me towards some basic C++ and theory-of-algorithms links). But field-testing showed that a simpler and faster approach was required - I needed something that gives consistent results on longer strings, like addresses and sentences, without the need for a separate scoring process that examines the word order.

The simplest approach of all to comparing and scoring for similarity is searching for the longest common string. This has the obvious advantages of speed and simplicity, but it alse has a weak point: simple LCS algorithms are unduly sensitive to single-letter substitutions and deletions near the midpoint of the test word. For example, 'Wednesday' is obviously closer to 'WedXesday' on an edit-distance basis than it is to 'WednesXXX', but the latter has the longest common string despite having more substitutions; this suggests that it would be better to score the 'Wed' as well as the 'eday', adding up all the matching substrings, instead of just measuring the longest one.

It turns out that the recursive algorithm I'm using to do this has an embedded sequence-sensitivity; in theory, this is a complication and a pretty heavy hint that there's some error in my logic that I ought to investigate and remove. In practice, a degree of sequence-sensitivity works well when we compare two sentences or phrases: this 'error' is a pretty good proxy for compiling a secondary score based on similarities in their word order.

Which goes to show that serendipidity comes from simplicity and, if you strip out the comments, this function is a commendably compact piece of code:

Public Function SumOfCommonStrings( _
            ByVal s1 As String, _
            ByVal s2 As String, _
            Optional Compare As VBA.VbCompareMethod = vbTextCompare, _
            Optional iScore As Integer = 0 _
                ) As Integer

Application.Volatile False

' N.Heffernan 06 June 2006 (somewhere over Newfoundland)
' THIS CODE IS IN THE PUBLIC DOMAIN

' Function to measure how much of String 1 is made up of substrings found in String 2

' This function uses a modified Longest Common String algorithm.
' Simple LCS algorithms are unduly sensitive to single-letter
' deletions/changes near the midpoint of the test words, eg:
' Wednesday is obviously closer to WedXesday on an edit-distance
' basis than it is to WednesXXX. So would it be better to score
' the 'Wed' as well as the 'eday' ?

' Watch out for strings of differing lengths:
'
'    SumOfCommonStrings("Wednesday", "WednesXXXday")
'
' This scores the same as:
'
'     SumOfCommonStrings("Wednesday", "Wednesday")
'
' So make sure the calling function uses the length of the longest
' string when calculating the degree of similarity from this score.

' This is coded for clarity, not for performance.

Dim arr() As Integer     ' Scoring matrix
Dim n As Integer         ' length of s1
Dim m As Integer         ' length of s2
Dim i As Integer         ' start position in s1
Dim j As Integer         ' start position in s2
Dim subs1 As String     ' a substring of s1
Dim len1 As Integer     ' length of subs1

Dim sBefore1             ' documented in the code
Dim sBefore2
Dim sAfter1
Dim sAfter2

Dim s3 As String

SumOfCommonStrings = iScore

n = Len(s1)
m = Len(s2)

If s1 = s2 Then
    SumOfCommonStrings = n
    Exit Function
End If

If n = 0 Or m = 0 Then
    Exit Function
End If

's1 should always be the shorter of the two strings:
If n > m Then
    s3 = s2
    s2 = s1
    s1 = s3
    n = Len(s1)
    m = Len(s2)
End If

n = Len(s1)
m = Len(s2)

' Special case: s1 is n exact substring of s2
If InStr(1, s2, s1, Compare) Then
    SumOfCommonStrings = n
    Exit Function
End If

For len1 = n To 1 Step -1

    For i = 1 To n - len1 + 1

        subs1 = Mid(s1, i, len1)
        j = 0
        j = InStr(1, s2, subs1, Compare)

        If j > 0 Then

         ' We've found a matching substring...
            iScore = iScore + len1

        ' Reinstate this Debug.Print statement to monitor the function:
        ' Debug.Print s1 & " substring (len=" & len1 & ") " & subs1 & " in " & s2 & " Scores " & len1

        ' Now clip out this substring from s1 and s2...

        ' However, we can't just concatenate the fragments before and
        ' after this deletion and restart: substrings that span this
        ' artificial join might give spurious matches. So we run the
        ' function on the separate 'before' and 'after' pieces. Note
        ' that running before1 vs before2 and after1 vs after2, without
        ' running before1 vs after2 and before2 vs after1, introduces
        ' a sequence bias. This may be undesirable, as the effect will
        ' be to discard match scores for transposed words in a sentence

            If i > 1 And j > 1 Then
                sBefore1 = left(s1, i - 1)
                sBefore2 = left(s2, j - 1)
                iScore = SumOfCommonStrings(sBefore1, _
                                            sBefore2, _
                                            Compare, _
                                            iScore)
            End If


            If i + len1 < n And j + len1 < m Then
                sAfter1 = right(s1, n + 1 - i - len1)
                sAfter2 = right(s2, m + 1 - j - len1)
                iScore = SumOfCommonStrings(sAfter1, _
                                            sAfter2, _
                                            Compare, _
                                            iScore)
            End If


            SumOfCommonStrings = iScore
            ' No further recursion: don't double-count substrings of a matched substring!
            Exit Function

        'Reinstate this 'Else' block to monitor the function:
        'Else
            ' No action required.
            ' Debug.Print s1 & " substring (len=" & len1 & ") " & subs1 & " in " & s2

        End If

    Next

Next

End Function

There is room for improvement, and I suspect that the embedded sequence sensitivity is a drawback in some applications. Consider these two addresses:

    The House of Cards,
    11 High Street,

and

    House of Cards, The
    11 High Street

They are clearly the same address, and this isn't even a typing error: moving 'The' to the end of the line (or titles like 'Mr' and 'Mrs') is accepted secretarial practice in lists that are sorted alphabetically. But my algorithm treats the transposed word 'The' as an insertion, applying a penalty without making any attempt to identify it as a transposition. In fact, it double-counts the transposition as two points of difference - deletion plus insertion - just like the unmodified Levenshtein edit-distance algorithm. So feel free to rewrite my code where it splits the test words into 'before' and 'after' fragments and resumes the search for matching substrings - but be warned, this is not as simple as you might think, and I don't see any obvious analogy with Damerau's extension of the Levenshtein algorithm. In practice the brutal excision of articles and titles from addresses is the most reliable approach.

A parting shot:

I have a vague suspicion that this sum-of-longest-common-strings algorithm is functionally equivalent to the Levenshtein edit distance, but I lack the logical tools to attempt a formal proof. Would anyone care to offer some pointers? I think its time I moved beyond simple hacks and started putting this stuff on a firmer foundation.

Unprotecting a project using VBA

2010-02-26T15:37:00.009Z

Ever tried to open another workbook call a macro in it from your VBA code?

Easy, if the sub or function is declared 'public' at workbook level and is visible as a method of the workbook object. If it isn't (and, sometimes, even if it is) and the VB Project is locked, you'll need to go into the VBE editor and unlock it yourself.

In short: manual intervention is required.

For obvious reasons, there's no Project.Unprotect(sPassword) function: obvious, but not good,and definitely not convenient when you've been asked to re-run all the reports in a month of separate daily workbooks.

We'll gloss over that your office should probably be handling the data and the daily reporting process in a more efficient way: sometimes you get this kind of job and the rest s up to you.

We'll assume that you know the password and have the right to open and run these files... now what?

There's code out there to unlock a project using a truly horrible combination of SendKeys() strings. THIS code is marginally better, but not miraculously so: it works on identifying the windows and the handles of the controls, and sending Windows messages using the API functions.

Most of the time the messages work... More often, anyway, than Sendkeys does. And, as we're in a slightly better environment than a keystroke-passer, we can read the results and retry the messages when they fail.

Here's the function:

fUnlockProject(wbk As Excel.Workbook, strPwd As String) As Boolean

I'm assuming that you know how to open a workbook in VBA: if you can't, then this code sample probably isn't for you. Not only is at an advanced topic - API calls and window messages - but we're doing something that VBA really isn't designed to do.

On top of that, Blogger's HTML editor (whatever RSS feed you're viewing the blog post in!) will have munged at least one of the line breaks and, while I've succeeded in getting thhe code below to copy-and-paste into a new VBA module, I suspect that some of you will get at least one syntax error when you try.

Finally: read the comments below the function header. There's stuff in there that you need to know about the return value, and a hint about passing the workbook object.

Option Explicit
Option Private Module

' Requires a reference to the library :
'   Microsoft Visual Basic for Applications Extensibility (v5.3)

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

    Private Declare Function SendMessageStr Lib "user32.dll" Alias "SendMessageA" ( _
          ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String _
       ) As Long

    Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" ( _
            ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long _
        ) As Long

    ' SetText params for SendMessage and PostMessage:

    ' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/windows/windowreference/windowmessages/wm_settext.htm
    '   wParam:         This parameter is not used.
    '   lParam:         Pointer to a null-terminated string that is the window text.
    '   Return Value:   The return value is TRUE if the text is set.


    ' API Window Message Constants are documented here:

    ' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/windows/windowreference/windowmessages/wm_close.htm
    ' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/shellcc/platform/commctls/buttons/buttonreference/buttonmessages/bm_click.htm

    Private Declare Function GetWindowTextApi Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function GetClassNameApi Lib "user32.dll" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

    Private Const WM_SETTEXT As Long = &HC
    Private Const WM_CLOSE As Long = &H10
    Private Const BM_CLICK = &HF5

    Private Const SW_HIDE = 0
    Private Const BM_SETCHECK As Long = &HF1&
    Private Const BST_UNCHECKED = &H0&
    Private Const BST_CHECKED As Long = &H1&
    Private Const BST_INDETERMINATE = &H2&
    Private Const EM_REPLACESEL As Long = &HC2&
    Private Const HWND_TOPMOST As Long = -1
    Private Const SWP_NOACTIVATE As Long = &H10&
    Private Const SWP_NOMOVE As Long = &H2&
    Private Const SWP_NOSIZE As Long = &H1&
    Private Const SWP_SHOWWINDOW As Long = &H40&

    Private Const TCM_SETCURFOCUS As Long = &H1330&

    ' Default Dialog control IDs
    Private Const IDOK As Long = 1
    Private Const IDCANCEL As Long = 2


'    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

    Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long

    Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, ByVal lpWindowName As String _
        ) As Long

    ' ms-help:'MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/dialogboxes/dialogboxreference/dialogboxfunctions/getdlgitem.htm
    ' Retrieves the handle to a control in the specified dialog box.
    ' hDlg      : [in] Handle to the dialog box that contains the control.
    ' nIDDlgItem: [in] Specifies the identifier of the control to be retrieved.
    ' returns   : The window handle of the specified control indicates success. NULL indicates failure due to an invalid dialog box handle or a nonexistent control.
    Private Declare Function GetDlgItem Lib "user32.dll" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long

    ' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/windows/windowreference/windowfunctions/setforegroundwindow.htm
    ' If the window was brought to the foreground, the return value is nonzero.
    ' If the window was not brought to the foreground, the return value is zero.
    Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hWnd As Long) As Long


    Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
    Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

    Private Declare Function CharLower Lib "user32.dll" Alias "CharLowerA" (ByVal lpsz As String) As String
    Private Declare Function CharUpper Lib "user32.dll" Alias "CharUpperA" (ByVal lpsz As String) As String


' Password windows caption suffix
Private Const DLG_PWD_CAP_SUFFIX As String = " Password"

' Project properties dialog caption suffix
Private Const DLG_PRJPROP_CAP_SUFFIX As String = " - Project properties"

' Project properties dialog hWnd
Private hWndProjectProperties As Long

' Caption of the dialog when a bad password is inserted
Private Const DLG_BADPWD_CAP As String = "Project Locked"

' Caption of the generic VBA error
Public Const DLG_VBERROR_CAP As String = "Microsoft Visual Basic"

' Dialog class
Private Const DIALOG_CLS As String = "#32770"

' Password dialog textfield control ID
Private Const PWD_DLG_EDIT_ID As Long = &H155E&

' Wait time for the windows search
Private Const WAIT_TIME As Long = 500
'
Public Function fUnlockProject(wbk As Excel.Workbook, strPwd As String) As Boolean
On Error Resume Next

' Unlock a VB project using a known password.

' You are advised to pass a wbk parameter that's opened in another Excel Application session.
' This one will probably crash if you try it locally.

' Returns True if all the dialog boxes were closed (indicating that the app can be safely closed).
' To know if the document project was unlocked successfully, use the .VBProject.Protection property.

' This code works by manipulating the windows of the VBE password dialogue in VBA.
' It's a step above the widely-published 'SendKeys' code. But that's faint praise:
' it's messy, and you'll soon find out why I use all those 'GoTo ...iRetry' blocks.

    Dim appExcel As Excel.Application
    Dim vbpProject As VBIDE.VBProject
    Dim vbEditor As VBIDE.VBE

    Dim i As Long
    Dim lStart As Long


    Dim sPPDlgCaption As String     ' Project Properties dialog caption
    Dim hDlgProjectProps As Long    ' Project Properties dialog handle

    Dim sPwdDlgCaption As String    ' password dialog caption
    Dim hDlgPassword As Long        ' password dialog handle

    Dim hPwdField As Long           ' password dialog textbox handle
    Dim hDlgBadPassword As Long     ' a 'Bad Password' dialog handle

    Dim iRetry As Long


    ' Menu bar
    '  \ Tools (msoControlPopup, ID:30007)
    '     \ Properties of ... (msoControlButton, ID:2578)

    Dim cbMenuBar As CommandBar
    Dim cbpTools As CommandBarPopup
    Dim cbbProperties As CommandBarButton
    Dim bDialogsCleared As Boolean

    bDialogsCleared = True

    'Application.EnableCancelKey = xlDisabled


    Set appExcel = wbk.Application
    Set vbEditor = appExcel.VBE
    Set vbpProject = wbk.VBProject

    ' show Visual Basic Editor?
'    If appExcel.VBE.MainWindow.visible = True Then
'        appExcel.VBE.MainWindow.visible = False
'    End If

    ' set the VBE active project
    Set vbEditor.ActiveVBProject = vbpProject

    ' construct the password dialog caption
    sPwdDlgCaption = vbpProject.Name & DLG_PWD_CAP_SUFFIX

    ' construct the 'project properties' dialog caption
    sPPDlgCaption = vbpProject.Name & DLG_PRJPROP_CAP_SUFFIX



    ' Note that this could be structured as nested IF... THEN blocks, avoiding the use of 'GOTO'
    ' But 'drop-through or exit' is easier to follow when we use a 'go-back-and-retry' structure

' Try to acquire the menu bar
iRetry = 0
RetryGetMenuBar:
iRetry = iRetry + 1

    If Not fGetMenuBar(vbEditor, cbMenuBar) Then

        ' Failed, retry 3 times
        Call Sleep(32 * iRetry)

        If iRetry < 4 Then
            GoTo RetryGetMenuBar
        Else
            Debug.Print vbpProject.Name & vbTab & "fUnlockProject() - Menubar not found : " & Err.Description
            GoTo ExitFunction
        End If

    End If  ' menu bar successfully acquired



' try to find the 'Tools' menu
iRetry = 0
RetryGetToolsMenu:
iRetry = iRetry + 1

    Set cbpTools = cbMenuBar.FindControl(ID:="30007")

    If (cbpTools Is Nothing) Then

        ' Failed, retry 3 times
        Call Sleep(32 * iRetry)

        If iRetry < 4 Then
            GoTo RetryGetToolsMenu
        Else
            Debug.Print vbpProject.Name & vbTab & "fUnlockProject() - Tools menu not found : " & Err.Description
            GoTo ExitFunction
        End If

     End If



' try to get the 'project properties' menu item
iRetry = 0
RetryGetProjProps:
iRetry = iRetry + 1


    Call fGetPopupItem(cbpTools, "2578", cbbProperties)
    CloseNamedDialog DLG_VBERROR_CAP

    If (cbbProperties Is Nothing) Then

        'Failed, Retry 3 times
        Call Sleep(32 * iRetry)

        If iRetry < 4 Then
            GoTo RetryGetProjProps
        Else
            Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Properties menu item not found."
            GoTo ExitFunction
        End If

    End If


    ' Execute the 'project properties' menu item action
    Call cbbProperties.Execute

    ' Test an unlikely outcome: the project properties window
    ' opened up straightaway, indicating there was no password:
    hDlgProjectProps = 0
    hDlgProjectProps = FindWindow(DIALOG_CLS, sPPDlgCaption)

    If hDlgProjectProps <> 0 Then
        GoTo ExitFunction
    End If



' Get the password dialog's window handle:

        hDlgPassword = 0
        hDlgPassword = FindWindow(DIALOG_CLS, sPwdDlgCaption)


' Test the  password dialog exists, retry if it does not:

iRetry = 0
RetryGetPwdDialog:
iRetry = iRetry + 1

        If hDlgPassword = 0 And iRetry < 3 Then

            ' Close any 'bad password' or VB Error windows
            CloseNamedDialog DLG_VBERROR_CAP
            CloseNamedDialog DLG_BADPWD_CAP

            ' Try getting the hWnd of the password dialog again:
            hDlgPassword = FindWindow(DIALOG_CLS, sPwdDlgCaption)

            If hDlgPassword = 0 Then
                Call Sleep(32 * iRetry)
            End If

            If hDlgPassword = 0 Then
                GoTo RetryGetPwdDialog
            End If

        End If

        If hDlgPassword = 0 And iRetry < 4 Then

            CloseNamedDialog DLG_VBERROR_CAP
            CloseNamedDialog DLG_BADPWD_CAP

            ' Try reopening the dialog from the menu, then get the hwnd:
            Call cbbProperties.Execute

            Call Sleep(32 * iRetry)
            hDlgPassword = (FindWindow(DIALOG_CLS, sPwdDlgCaption))

            If hDlgPassword = 0 Then
                Call Sleep(32 * iRetry)
            End If

            If hDlgPassword = 0 Then
                GoTo RetryGetPwdDialog
            End If

        End If

        If hDlgPassword = 0 Then
            Debug.Print vbpProject.Name & vbTab & "fUnlockProject(): cannot open the password dialog."
            GoTo ExitFunction
        End If


' Get the password textbox

        hPwdField = 0
        hPwdField = GetDlgItem(hDlgPassword, PWD_DLG_EDIT_ID)


' Test the password textbox exists, retry if it does not:

iRetry = 0
RetryGetPwdTextbox:
iRetry = iRetry + 1

        If hPwdField = 0 And iRetry < 4 Then

            CloseNamedDialog DLG_VBERROR_CAP
            CloseNamedDialog DLG_BADPWD_CAP

            hPwdField = GetDlgItem(hDlgPassword, PWD_DLG_EDIT_ID)

            If hPwdField = 0 Then
                Call Sleep(32 * iRetry)
            End If

            If hPwdField = 0 Then
                GoTo RetryGetPwdTextbox
            End If
         End If

        If hPwdField = 0 Then
            Debug.Print vbpProject.Name & vbTab & "fUnlockProject(): cannot find the password textbox."
            bDialogsCleared = CloseWindow(hDlgPassword)
            GoTo ExitFunction
        End If


'Fill in the password text:
iRetry = 0
RetrySetText:
iRetry = iRetry + 1

        If SendMessageStr(hPwdField, WM_SETTEXT, 0&, strPwd) = 0 Then

            ' zero return indicates a failed set-text operation
            Call Sleep(32 * iRetry)

            Select Case iRetry
            Case Is < 4
                GoTo RetrySetText
            Case Is < 5
                CloseNamedDialog DLG_VBERROR_CAP
                CloseNamedDialog DLG_BADPWD_CAP
                hDlgPassword = (FindWindow(DIALOG_CLS, sPwdDlgCaption))
                hPwdField = GetDlgItem(hDlgPassword, PWD_DLG_EDIT_ID)
                GoTo RetrySetText
            Case Is < 6
                CloseNamedDialog DLG_VBERROR_CAP
                CloseNamedDialog DLG_BADPWD_CAP
                CloseWindow hDlgPassword
                GoTo RetryGetPwdDialog
            Case Else
                Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Unable to enter password '" & strPwd & "' into the textbox."
                bDialogsCleared = CloseWindow(hDlgPassword)
                GoTo ExitFunction
            End Select

        End If


' Click the 'Ok' button
iRetry = 0
RetryClickOK:
iRetry = iRetry + 1


        ' PostMessage returns the results of the 'click': nonzero indicates success
        If PostMessage(GetDlgItem(hDlgPassword, IDOK), BM_CLICK, 0&, 0&) = 0 Then

            Select Case iRetry
            Case Is < 4
                Call Sleep(32 * iRetry)
                GoTo RetryClickOK
            Case 4
                CloseNamedDialog DLG_BADPWD_CAP
                CloseNamedDialog DLG_VBERROR_CAP
                Call SetForegroundWindow(hDlgPassword)
                GoTo RetryClickOK
            Case Else
                Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Unable to click 'OK' for this password."
                bDialogsCleared = CloseWindow(hDlgPassword)
                GoTo ExitFunction
            End Select

        End If ' fClickButton failed


        ' fClickButton returned true, telling us that control
        ' has returned to the OK button's parent dialog.

        ' However, that could also mean that the button wasn't clicked at all:

        hDlgPassword = 0
        hDlgPassword = FindWindow(DIALOG_CLS, sPwdDlgCaption)

        If hDlgPassword <> 0 Then

            Select Case iRetry
            Case Is < 4
                Call Sleep(32 * iRetry)
                GoTo RetryClickOK
            Case 4
                CloseNamedDialog DLG_BADPWD_CAP
                CloseNamedDialog DLG_VBERROR_CAP
                Call SetForegroundWindow(hDlgPassword)
                GoTo RetryClickOK
            Case Else
                Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Unable to click 'OK' for this password."
                bDialogsCleared = CloseWindow(hDlgPassword)
                GoTo ExitFunction
            End Select

        End If

        bDialogsCleared = False




' Inspect the results of the click

' No retry block here: retrying Window-open operations, clicks and SetTexts is fine
' - or rather, a messy necessity - but the password itself either worked or failed.

' Two possible outcomes:   1 Password success opened a 'project properties' dialog
'                          2 Password failure opened a 'bad password' dialog



        If CloseNamedDialog(DLG_BADPWD_CAP) = 0 Then  ' no 'bad password' dialog to close

            hDlgProjectProps = 0
            hDlgProjectProps = FindWindow(DIALOG_CLS, sPPDlgCaption)

            If hDlgProjectProps = 0 Then
                Call Sleep(250)
            End If

            If hDlgProjectProps <> 0 Then

                ' Opened the 'Properties' screen, which means: PASSWORD SUCCESSFUL!
                Debug.Print "PASSWORD: " & strPwd & vbTab & wbk.FullName

                'Close the project properties dialog: try the OK button first
                bDialogsCleared = fClickButton(hDlgProjectProps, IDOK)

            End If 'successful password

        Else
            ' Bad password dialog detected & closed... Our password Failed

        End If


ExitFunction:

    CloseNamedDialog DLG_BADPWD_CAP
    CloseNamedDialog DLG_VBERROR_CAP
    hDlgProjectProps = FindWindow(DIALOG_CLS, sPPDlgCaption)
    bDialogsCleared = bDialogsCleared And CloseWindow(hDlgPassword) And CloseWindow(hDlgProjectProps)


    If (bDialogsCleared) Then
        ' all the dialog boxes were closed
        fUnlockProject = True
    End If

    Set cbbProperties = Nothing
    Set cbpTools = Nothing
    Set cbMenuBar = Nothing

    vbEditor.MainWindow.Close

    Set vbEditor = Nothing
    Set appExcel = Nothing

End Function

Private Function fGetDialogHnd(sCaption, hDlg As Long) As Boolean

' Get the handle of the dialog whose the caption is specified.
' Return True if the dialog was found.

    hDlg = (FindWindow(DIALOG_CLS, sCaption))
    fGetDialogHnd = (hDlg <> 0)

End Function

Private Function fClickButton(hDlg As Long, lButtonID As Long) As Boolean

' Programmatically click on a button in a command bar or menu,  specified by ID
' Return False if the button owner was not activated or the 'click' failed

    Dim hButton As Long

    ' get the button handle
    hButton = GetDlgItem(hDlg, lButtonID)

    ' active the dialog box (hDlg) and click on the button
    If PostMessage(hButton, BM_CLICK, 0&, 0&) <> 0 Then
        fClickButton = True
    End If

End Function

Private Function fGetMenuBar(oContainer As Object, cb As CommandBar) As Boolean

' Get the menu bar of the specified container:
' oContainer can be any object which has a CommandBars collection.
' Return True if the menu bar was found.

    Dim i As Long

    On Error Resume Next
    For i = 1 To oContainer.CommandBars.Count
        Set cb = oContainer.CommandBars(i)

        If (cb.Type = msoBarTypeMenuBar) Then
            fGetMenuBar = True
            Exit For
        End If
    Next i
    On Error GoTo 0

End Function

Private Function fGetPopupItem(cbp As CommandBarPopup, sControlID As String, cbc As CommandBarControl) As Boolean
' Get a control from a commandbar or menu, by specifying the control's ID

    Dim i As Long

    For i = 1 To cbp.Controls.Count

        Set cbc = cbp.Controls(i)

        If (cbc.ID = sControlID) Then
            fGetPopupItem = True
            Exit For
        End If

    Next i


End Function

Private Function TrimNulls(ByVal sString As String) As String
' Trims trailing nulls

Dim iPos As Integer

iPos = InStr(sString, Chr$(0))

    Select Case iPos
    Case 0

        TrimNulls = sString

    Case 1

        TrimNulls = ""

    Case Else ' iPos > 1

        TrimNulls = left$(sString, iPos - 1)

    End Select

End Function

Private Function fUCase(ByVal sString As String) As String

    If (Len(sString) >= 2) Then
        fUCase = CharUpper(left$(sString, 1)) & _
                 CharLower(right$(sString, Len(sString) - 1))
    Else
        fUCase = sString
    End If

End Function

Private Function IsArrayEmpty(va As Variant) As Boolean
' Incorporates fix from Torsten Rendelmann (MVPS - Hardcore VB)
    Dim i As Long

    On Error Resume Next
    i = LBound(va, 1)
    IsArrayEmpty = (Err.Number <> 0)
    On Error GoTo 0 ' Err.Clear

End Function

Private Function CloseWindow(hWnd As Long) As Boolean

Dim iRetry As Integer

CloseWindow = False

RetryCloseWindow:
iRetry = iRetry + 1

    If SendMessage(hWnd, WM_CLOSE, 0&, 0&) = 0& Then

        CloseWindow = True

    Else

        CloseWindow = False
        CloseNamedDialog DLG_VBERROR_CAP
        Call Sleep(32 * iRetry)

        If iRetry < 4 Then
            GoTo RetryCloseWindow
        End If

    End If

End Function

Public Function CloseNamedDialog(sDialogCaption As String) As Long
'Returns window handle of last-closed window
On Error Resume Next

Dim iCount As Integer
Dim hwnDialog As Long

Err.Clear

CloseNamedDialog = 1

hwnDialog = FindWindow(DIALOG_CLS, sDialogCaption)

Do Until hwnDialog = 0
iCount = iCount + 1

    SendMessage hwnDialog, WM_CLOSE, 0&, 0&
    CloseNamedDialog = hwnDialog
    hwnDialog = FindWindow(DIALOG_CLS, sDialogCaption)


    If iCount > 1 Then
        Sleep 10 * iCount
        SetFocus hwnDialog
    End If

    If iCount > 3 Then
        ' something's stopping us closing the window
        Exit Do
    End If

Loop

End Function

Public Sub CloseGenericError()
On Error Resume Next

    CloseNamedDialog DLG_VBERROR_CAP
    Application.OnTime EarliestTime:=Now() + (1# / 24# / 1200#), Procedure:="CloseGenericError"

End Sub

Private Function ClickButton(hWndOwner As Long, hWndButton As Long) As Boolean
On Error Resume Next

    SetForegroundWindow hWndOwner
    SetFocus hWndButton
    PostMessage hWndButton, BM_CLICK, 0&, 0&

End Function

Private Function GetWindowText(ByVal hWnd As Long) As String

Dim sBuffer As String
Dim lBufferLen As Long

    sBuffer = String$(512, 0)
    lBufferLen = GetWindowTextApi(hWnd, sBuffer, Len(sBuffer))
    GetWindowText = left$(sBuffer, lBufferLen)

End Function

Private Function GetClassName(ByVal hWnd As Long) As String

Dim sBuffer As String
Dim lBufferLen As Long

    sBuffer = String$(512, 0)
    lBufferLen = GetClassNameApi(hWnd, sBuffer, Len(sBuffer))
    GetClassName = left$(sBuffer, lBufferLen)

End Function

A VBA function to force calculation of a cell's precedents

2009-12-02T23:01:00.003Z

Here's some code I hope you don't need: a targeted 'recalculate' function.

Most Excel developers don't get huge workbooks that take twenty minutes to recalculate... It's our job to stop this kind of thing, right? But if you do, how do you get just one bit of the monster to calculate - the bit you're trying to debug, or explain the strange results in - when there's a long, long chain of dependencies on market data sources and external math libraries? The one thing you don't want to do is recalculate the whole workbook, but recalculating the cell with the F2 key is useless because it doesn't go right down the 'precedents' (Microsoft's term for the chain of cells and ranges that feed into your cell), no matter what you read in the documentation.

So I started writing a tool to record the chain of precedents, and found that really complex spreadsheets could produce so much dependency data that the text output was impossible to assimilate. What I found out next was that presenting this mass of data in a structured way breaks down because there are no tools that can represent cross-linkage without turning into a visual spaghetti, and the only good tool for representing the mess as a branching structure - the treeview control - is unstable in Excel at the best of times and blows up if there's more than 16 layers of recursion or more than 255 subnodes in any given node.

But the end result of this failed project was a tool that could explore the precedents, list them in a collection and, having discovered all the sources leading into a cell, back it's way out of the dependency chain while only calculating each cell once. That's efficient - not as quick as Excel's internal dependency chain, but it's often quicker than recalculating an over-complicated workbook. And it works a treat when Excel's dependency tree is broken, or blocked by named ranges, indirect references, and third-party libraries which place range pointers in a cell instead of range addresses.

Feel free to post your code if you get a visualisation tool to work! Also, please let me know if you can think of a way of identifying homogeneous blocks of formulae and enumerating them in one go, instead of repeating the search on cell after cell. It's not that it can't be done, but I can't see a way of doing it reliably and quickly enough to use on thousands of formulae.

Anyway, here's the code, complete with a snippet for putting it into an add-in and populating the popup 'cell' menu with a button that calls the function. As always, beware of spurious line breaks and syntax errors introduced by the Blogger platform's automatic formatting.

Option Explicit
Option Private Module

Private Sub CalculatePrecedents(rngCalc As Excel.Range, Optional bVerbose As Boolean = False)

' Recursive function to force calculation of a dependency chain
' with additional coding to prevent searching any range twice

On Error Resume Next

Static iRecurse As Long
Static colRanges As Scripting.Dictionary
Static colWorkbooks As Scripting.Dictionary
Static xlPriorCalcSetting As XlCalculation
Static iSearched As Long
Static iCalculated As Long
Static arrNames() As String
Static iCountNames As Long
Static sWorkbookName As String

Dim iCountPrecedents As Long
Dim rPrecedent As Excel.Range
Dim rCell As Excel.Range
Dim myName As Excel.Name
Dim strName As String
Dim strAddress As String
Dim strFormula As String
Dim iLen As Long
Dim i As Integer
Dim iMatch As Integer
Dim iNextChar As Integer
Dim iPrevChar As Integer
Dim boolIsName As Boolean

' Do we need new collections for the searched formulae and calculated ranges?
If iRecurse = 0 Or rngCalc.Worksheet.Parent.Name <> sWorkbookName Then

    If colWorkbooks Is Nothing Then
        Set colWorkbooks = New Scripting.Dictionary
    End If

    ' save sets for current workbook
    If Not (colWorkbooks.Exists("Ranges: " & sWorkbookName) Or colRanges Is Nothing) Then
        colWorkbooks.Add "Ranges: " & sWorkbookName, colRanges
    End If

    ' retrieve sets for newly-discovered workbook
    sWorkbookName = rngCalc.Worksheet.Parent.Name
    If colWorkbooks.Exists("Ranges: " & sWorkbookName) Then
        Set colRanges = colWorkbooks("Ranges: " & sWorkbookName)
    Else
        Set colRanges = Nothing
    End If

End If

If colRanges Is Nothing Or iRecurse = 0 Then

    xlPriorCalcSetting = Application.Calculation

    ' Initialise the collection that prevents checking the same range twice:
    Set colRanges = New Scripting.Dictionary

    ' initialise and populate the array of names: this is used for a fast
    ' search to see if a named range is referenced in a formula - a test
    ' that isn't reliably executed by Excel's native 'precedents' function

    iCountNames = rngCalc.Worksheet.Parent.Names.Count


    Application.StatusBar = "Trace precedents: collating named range addresses in " & sWorkbookName & "..."

    If bVerbose = True Then
        Debug.Print "Trace precedents: collating named range addresses in " & sWorkbookName & "..."
    End If

    If iCountNames > 0 Then

        ReDim arrNames(1 To iCountNames)

        For i = 1 To iCountNames

            strName = ""
            strName = rngCalc.Worksheet.Parent.Names(i).NameLocal

            If InStr(1, strName, "!") > 0 Then
                strName = left(strName, InStr(1, strName, "!") - 1)
            End If

            arrNames(i) = strName

        Next i

        ' Sort in descending order: looking for the longest names first allows us
        ' to prevent a match on 'ABCDE' being masked by finding 'BCD'

        BubbleSortOnLen arrNames, xlDescending


    End If '  iCountNames > 0

    Application.StatusBar = "Trace precedents: analysing first cell..."

    If bVerbose = True Then
        Debug.Print "Trace precedents: analysing first cell... '" & rngCalc.Worksheet.Name & "'!" & rngCalc.Address
    End If

End If

' Check for ranges we've searched before.

' First check: it might be a single cell; if so, is it part of an array we've already analysed?
If rngCalc.Cells.Count = 1 Then
    If rngCalc.HasArray Then

        If colRanges.Exists("'" & rngCalc.Worksheet.Name & "'!" & rngCalc.CurrentArray) Then
           GoTo ExitSub
        Else
            colRanges.Add "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.CurrentArray, "Recursion " & CStr(iRecurse) & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & "{" & rngCalc.Formula & "}"
        End If

    End If

    ' Exit if there's no formula; there can be no precedents
    ' Note that we had to check it wan't an array beforehand
    If Not (IsNull(rngCalc.HasFormula) Or (rngCalc.HasFormula = True)) Then
        GoTo ExitSub
    End If

End If  ' rngCalc.Cells.Count = 1

' Check that we haven't searched this range already - there's an overhead doing this, but it's better than repeated search and calculation
If colRanges.Exists("'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal) Then
    GoTo ExitSub
Else
    colRanges.Add "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal, "Recursion " & CStr(iRecurse) & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal
End If

' Keep track of recursion: this tells us when the search has been completed
If iRecurse < 0 Then
    iRecurse = 0
End If

If iSearched Mod 10 = 0 Then
    Application.StatusBar = "Trace precedents: searched " & Format(iSearched, "#,##0") & "    Calculated " & Format(iCalculated, "#,##0") & "    Recursion level " & iRecurse & "    Cell '" & rngCalc.Worksheet.Name & "'!" & rngCalc.Address
End If

If bVerbose = True Then
    Debug.Print "Trace precedents - search " & iSearched & ":" & vbTab & " Precedents of " & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & " Formula: " & rngCalc.Formula & vbTab & " at recursion level " & iRecurse
End If

If rngCalc.Cells.Count = 1 Then

    strFormula = ""
    strFormula = LTrim(rngCalc.Formula)

    ' Check for named ranges in the formula: these are not
    ' recognized as reliably as "A1" specified addresses
    ' and will therefore not be recognised as precedents

    For i = 1 To iCountNames Step 1

        strName = ""
        strName = arrNames(i)


        iMatch = InStr(1, strFormula, strName, vbTextCompare)
        If iMatch > 0 Then

            boolIsName = True

            ' A name like "res" might well be a substring of another name, or of a
            ' function name. So we must establish that the string we've found isn't
            ' just a match for a named range: it's got to be in use as an address.

            iLen = Len(strName)
            iPrevChar = 0
            iNextChar = 0

            If iMatch + iLen = Len(strFormula) Then
                iNextChar = 0
            Else
                iNextChar = iMatch + iLen + 1

                Select Case Mid(strFormula, iNextChar, 1)
                Case "(", Chr(34), ".", "!", "a" To "z", "A" To "Z", 0 To 9
                    'strName definitely isn't a named range
                    boolIsName = False
                Case Else
                    ' no action... move to next test
                End Select

            End If

            If iMatch > 1 Then

                iPrevChar = iMatch - 1

                Select Case Mid(strFormula, iPrevChar, 1)
                Case Chr(34), ".", "!", "a" To "z", "A" To "Z", 0 To 9
                    'strName definitely isn't a named range
                    boolIsName = False
                Case Else
                    ' no action... move to next test
                End Select
            End If

            If boolIsName Then

                iSearched = iSearched + 1
                iRecurse = iRecurse + 1
                CalculatePrecedents rngCalc.Worksheet.Parent.Names(strName).RefersToRange, bVerbose
                iRecurse = iRecurse - 1

                ' Strip the matched name out of our formula string, so we only analyse it once:
                strFormula = Application.WorksheetFunction.Substitute(strFormula, strName, "")

            End If 'boolIsName

        End If

    Next i

    iCountPrecedents = 0
    iCountPrecedents = rngCalc.DirectPrecedents.Count

    If iCountPrecedents > 0 Then

        For Each rPrecedent In rngCalc.DirectPrecedents
            iSearched = iSearched + 1
            iRecurse = iRecurse + 1
            CalculatePrecedents rPrecedent, bVerbose
            iRecurse = iRecurse - 1
        Next

    End If ' .DirectPrecedents.Count = 0

Else

    ' unless it's an array formula, search each cell
    If IsNull(rngCalc.FormulaArray) Then

        For Each rCell In rngCalc.SpecialCells(xlCellTypeFormulas)

            If rCell.HasFormula Then
                iSearched = iSearched + 1
                iRecurse = iRecurse + 1
                CalculatePrecedents rCell, bVerbose
                iRecurse = iRecurse - 1
            End If

        Next rCell

    Else

        ' for an array, run the precedents of the entire range:
        For Each rPrecedent In rngCalc.DirectPrecedents
            iSearched = iSearched + 1
            iRecurse = iRecurse + 1
            CalculatePrecedents rPrecedent, bVerbose
            iRecurse = iRecurse - 1
        Next

    End If

End If ' cells.count = 1

iCalculated = iCalculated + 1

If bVerbose = True Then
    Debug.Print "Calculating cell " & iCalculated & " (recursion layer " & iRecurse & "): " & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & vbTab & rngCalc.Formula
End If

If bVerbose = True Then
    Debug.Print vbTab & "Trace precedents - Calculation " & iCalculated & ":" & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & " Formula: "; vbTab & rngCalc.Formula & " at recursion level " & iRecurse
End If

rngCalc.Calculate

ExitSub:


    If iRecurse < 0 Then  ' this is redundant in production code, but it'll save you grief in development
        iRecurse = 0
    End If


    If iRecurse = 0 Then

        If bVerbose = True Then
            Application.StatusBar = "Trace precedents searched " & Format(iSearched, "#,##0") & "    Calculated " & Format(iCalculated, "#,##0") & "    Recursion returned to " & iRecurse
        End If

        Erase arrNames
        Application.StatusBar = False
        iSearched = 0
        iCalculated = 0
        Set colRanges = Nothing
        Application.Calculation = xlPriorCalcSetting

    End If


End Sub

Private Sub BubbleSortOnLen(ByRef arrStrings() As String, Optional SortOrder As Excel.XlSortOrder = xlAscending)
' Modified Bubble Sort: sort an array of strings by length

Dim iFirst  As Integer
Dim iLast   As Integer
Dim i       As Integer
Dim j       As Integer
Dim sTemp   As String


    iFirst = LBound(arrStrings)
    iLast = UBound(arrStrings)

    If SortOrder = xlAscending Then

        For i = iFirst To iLast - 1
            For j = i + 1 To iLast
                If Len(arrStrings(i)) > Len(arrStrings(j)) Then
                    sTemp = arrStrings(j)
                    arrStrings(j) = arrStrings(i)
                    arrStrings(i) = sTemp
                End If
            Next j
        Next i

    Else   ' SortOrder = xlDescending

        For i = iFirst To iLast - 1
            For j = i + 1 To iLast
                If Len(arrStrings(i)) < Len(arrStrings(j)) Then
                    sTemp = arrStrings(j)
                    arrStrings(j) = arrStrings(i)
                    arrStrings(i) = sTemp

                End If

            Next j
        Next i

    End If ' sortorder

End Sub

Public Sub CalculateSelection()
' Called from a button in a menubar or popup

On Error Resume Next
    Selection.Calculate

End Sub

Public Sub GetPrecedents()
' Called from a button in a menubar or popup

    CalculatePrecedents Selection, False

End Sub

And here's the boilerplate code that puts Calculate Precedents into an add-in's 'Workbook' object module and adds our function to the right-click popup menu for an Excel worksheet:

Option Explicit

Private Sub Workbook_AddinInstall()

Dim objCbtn As Office.CommandBarButton
Dim objCbtn2 As Office.CommandBarButton
Dim objCbar As Office.CommandBar

With Application.CommandBars("Cell")

    Set objCbtn = .FindControl(, , "Calculate Precedents", , True)

    Do Until objCbtn Is Nothing
        objCbtn.Delete
        Set objCbtn = .FindControl(, , "Calculate Precedents", , True)
    Loop

    Set objCbtn = .Controls.Add(msoControlButton, , , , True)


End With  'Application.CommandBars("Cell")

With objCbtn

    .BeginGroup = True
    .Caption = "Calculate Precedents"
    .DescriptionText = "Locate all precedents and calculate recursively"
    .OnAction = "GetPrecedents"
    .Tag = "Calculate Precedents"
    .TooltipText = "Locate all precedents and calculate recursively"
    .FaceId = 452

End With 'objCbtn

Set objCbtn = Nothing

With Application.CommandBars("Cell")

    Set objCbtn = .FindControl(, , "Calculate Selection", , True)

    Do Until objCbtn Is Nothing
        objCbtn.Delete
        Set objCbtn = .FindControl(, , "Calculate Selection", , True)
    Loop

    Set objCbtn = .Controls.Add(msoControlButton, , , , True)

End With  'Application.CommandBars("Cell")

With objCbtn

    .Caption = "Calculate Selection"
    .OnAction = "CalculateSelection"
    .Tag = "Calculate Selection"
    .TooltipText = "Calculate the selected range"
    .FaceId = 346

End With 'objCbtn

Set objCbtn = Nothing

End Sub

Private Sub Workbook_AddinUninstall()

Dim objCbtn As Office.CommandBarButton

With Application.CommandBars("Cell")

    Set objCbtn = .FindControl(, , "Calculate Precedents", , True)

    If Not objCbtn Is Nothing Then
        objCbtn.Delete
    End If


    Set objCbtn = .FindControl(, , "Calculate Selection", , True)

    If Not objCbtn Is Nothing Then
        objCbtn.Delete
    End If

End With  'Application.CommandBars("Cell")

Set objCbtn = Nothing

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Call Workbook_AddinUninstall

End Sub

Private Sub Workbook_Open()

Call Workbook_AddinInstall

End Sub

Who owns that file? Using WMI to identify the owner of a file

2009-12-01T15:22:00.002Z

Every now and again, I have the job of archiving vast numbers of workbooks: a penance for failing to move the users on from using Excel for primary data storage and saving down each day's valuations in a separate sheet.

As you can imagine, this gets tedious, and it needs automating... Any fool can write a script to delete, zip or move files around, and many fools have done so: few were so damned by their actions in a past life as to be doomed to notify the file owners by email.

But who owns the file?

Every now and again, Windows shows that a simple question can be made to have an absurdly difficult answer, and finding the owner of a named file is one of the worst I've come across. The API calls have been analysed and explained by Emmet Gray:

http://www.emmet-gray.com/Articles/GetOwner.htm

You are welcome to read it and try out the code: it is a remarkable feat of analysis and simplification in the face of the wilfully illogical and obscure and, despite being pared down and superbly documented, it is a truly intimidating piece of API coding. You cannot extract the Security Descriptor of a file in less than a hundred lines of code and, when you've got it, you will rapidly realise that opening up and interrogating a file's Security Descriptor for the SID of the user only leads to an even deeper travail in extracting a human-readable user name. I do not believe that it can be done in less than a thousand lines of code and I would question whether it can be done reproducibly and reliably - let lone clearly - which is to say that it probably shouldn't be done in VBA.

But I've still got the job of digging out the user names for all the files I'm archiving. The code snippet below uses WMI - Windows Management Information - a truly horrible API released (but not documented) by Microsoft for systems administrators. If WMI is an improvement, I shudder to think what they had to do before it existed, and I am astonished that the haven't all turned into the BOFH (Look it up. But not at work). But it is at least short. All it is, is a 'Get Owner' function and a small Scripting wrapper that searches a folder and lists the files...

Private Function GetFileOwner(strFile As String, Optional WithDomainName As Boolean = False) As String

' Returns the owner of a file or folder, or a comma-delimited list if there are multiple owners.

' Usage:
'     Debug.Print GetFileOwner("H:\Personal\MyFile.txt")
'       heffernann
'
'     Debug.Print GetFileOwner("H:\Personal\MyFile.txt", TRUE)
'       OLYMPUS\heffernann
'
'     Debug.Print GetFileOwner("\\OLYMPUS\Users\heffernann\Personal\MyFile.txt", TRUE)
'       [returns nothing, see below]

' This works with local drives and mapped drives, but fully-qualified network paths do not work.
' According to the documentation, WMI will return an error when the file owner is a user who has
' been purged from the system. However, all that happens here is that we get an empty collection

' Author: Nigel Heffernan

' The underlying technology is WMI (Windows Management Information).
' The WMI documentation is very poor, even by the standards of MSDN.
' However, Microsoft's 'Hey! Scripting Guy!' site has usable information:

'   http://www.microsoft.com/technet/scriptcenter/resources/qanda/oct04/hey1007.mspx

Static objWMIService As Object      ' Persistent object: this is called repeatedly,
                                    ' so you may prefer to declare it at module level
                                    ' and instantiate/dismiss it explicitly

Dim colItems As Object
Dim objItem As Object

Dim strComputer As String
Dim strWMI_Query As String
Dim strOwner As String
Dim strOutput As String
Dim iCount As Integer

Const wbemFlagReturnImmediately As Long = 16
Const wbemFlagForwardOnly As Long = 32
Dim IFlags As Long

    IFlags = wbemFlagReturnImmediately + wbemFlagForwardOnly

    strComputer = "."   ' WMI notation for 'This machine'
                        ' WMI script sometimes works if remote machine names are specified
                        ' but you'll need to specify the local path when looking up files

    strWMI_Query = ""
    strWMI_Query = strWMI_Query & "ASSOCIATORS OF "
    strWMI_Query = strWMI_Query & "{Win32_LogicalFileSecuritySetting='" & strFile & "'}"
    strWMI_Query = strWMI_Query & " WHERE AssocClass=Win32_LogicalFileOwner ResultRole=Owner"


' WMI Association classes can be instantiated directly, but the syntax is arcane.
' Querying the WMI data service is simpler, if you can find a pre-existing query template

    If objWMIService Is Nothing Then
        Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    End If

    ' ExecQuery is relatively easy to do, but rather slow
    Set colItems = objWMIService.ExecQuery(strWMI_Query, , IFlags)

    ' AssociatorsOf is faster, and is documented here: http://msdn.microsoft.com/en-us/library/aa393858(VS.85).aspx
    'Set colItems = objWMIService.AssociatorsOf("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2", "Win32_LogicalFileOwner", "SWbemObjectEx", "Owner", , , , , , IFlags)

    strOutput = ""
    iCount = 0
    On Error Resume Next

        For Each objItem In colItems

            strOwner = ""
            If WithDomainName Then
                strOwner = objItem.ReferencedDomainName & "\" & objItem.AccountName
            Else
                strOwner = objItem.AccountName & ","
            End If

            strOutput = strOutput & strOwner

        Next objItem

'Trim trailing comma:

    strOutput = Trim(strOutput)
    If Len(strOutput) > 0 Then
        strOutput = Left(strOutput, Len(strOutput) - 1)
    End If

    GetFileOwner = strOutput

End Function

Public Sub RecurseFolder(strFolder As String, Optional RecursionLevel As Integer = 0, Optional minDateLastModified As Date = 0, Optional minSize As Double = 0)

' Recursive Subroutine to enumerate the contents of an NT folder.
' Writes the results to a log file

' Subfolders are enumerated by a recursive call
' For use in Excel VBA: can be converted to VBScript

' REQUIRES module-level declarations:

'       objLogStream (Scripting.TextStream)
'       objFSO (Scripting.FileSystemObject)
'       LogfileName  (string)

' REQUIRES Subroutines and Functions:

'       GetFileOwner
'       Logfile
'       CloseLogFile

' VBA Declarations:
Dim objFolder As Folder
Dim objSubFolder As Folder

Dim objFile     As File
Dim strFile     As String
Dim strMessage  As String
Dim strOwner    As String
Dim strSize     As String
Dim lngCountLog As Long

If objFSO Is Nothing Then
    Set objFSO = New FileSystemObject
End If

Set objFolder = objFSO.GetFolder(strFolder)

Application.StatusBar = "Searching folders: " & RecursionLevel & " layers: " & strFolder

' Use this if you're reporting progress on a worksheet (requires named range as shown):
ThisWorkbook.Names("CurrentFolder").RefersToRange.Value = strFolder

strOwner = GetFileOwner(objFolder.Path)

On Error Resume Next

strMessage = ""
strMessage = strMessage & "FOLDER" & vbTab & objFolder.name & vbTab & 0 & vbTab & objFolder.DateLastModified & vbTab & objFolder.DateLastAccessed & vbTab & strOwner & vbTab & objFolder.Path & vbTab & RecursionLevel
Logfile strMessage

    lngCountLog = 0

    For Each objFile In objFolder.Files

            strFile = objFile.Path

            If objFile.DateLastModified >= minDateLastModified Then

                If objFile.Size >= minSize Then

                    strOwner = ""
                    strOwner = GetFileOwner(objFile.Path)

                    strMessage = ""
                    strMessage = strMessage & "FILE" & vbTab & objFile.name & vbTab & objFile.Size & vbTab & objFile.DateLastModified & vbTab & objFile.DateLastAccessed & vbTab & strOwner & vbTab & objFolder.Path & vbTab & RecursionLevel
                    Logfile strMessage

                    lngCountLog = lngCountLog + 1

                End If  'objFile.Size > minSize Then

            End If ' objFile.DateLastModified > minDateLastModified

    Next objFile

    ' Use these f you're reporting progress on a worksheet (requires named ranges as shown):
    ThisWorkbook.Names("CurrentCount").RefersToRange.Value = ThisWorkbook.Names("CurrentCount").RefersToRange.Value + objFolder.Files.Count
    ThisWorkbook.Names("CurrentCountLogged").RefersToRange.Value = ThisWorkbook.Names("CurrentCountLogged").RefersToRange.Value + lngCountLog

    For Each objSubFolder In objFolder.SubFolders

        RecursionLevel = RecursionLevel + 1
        RecurseFolder objSubFolder.Path, RecursionLevel, minDateLastModified, minSize
        RecursionLevel = RecursionLevel - 1

    Next objSubFolder

End Sub

Public Sub Logfile(strMessage)

' Stream a message to a log file
' Opens the file if required.
' You are advised to close the file explicitly when your process has completed: use CloseLogFile for this

' REQUIRES module-level declarations:

'       objLogStream (Scripting.TextStream)
'       objFSO (Scripting.FileSystemObject)
'       LogfileName  (string)

Dim strHeader As String

If objLogStream Is Nothing Then
    Set objLogStream = objFSO.OpenTextFile(LogfileName, ForWriting, True)
    strHeader = "Type" & vbTab & "Filename" & vbTab & "Size" & vbTab & "DateLastModified" & vbTab & "DateLastAccessed" & vbTab & "Owner" & vbTab & "ParentFolder" & vbTab & "PathDepth"
    objLogStream.WriteLine strHeader
End If

objLogStream.WriteLine strMessage

End Sub

Public Sub CloseLogFile()

If objLogStream Is Nothing Then
    Exit Sub
End If

objLogStream.Close
Set objLogStream = Nothing

End Sub

Feel free to try out the code - and do, please, feel free to tell me how you got on. Oh, and watch out for line breaks imposed by Blogger's atomatic formatting.

Detecting an array variant in Excel VBA

2009-02-04T02:32:00.008Z

This will return 0 for scalar variables and a positive integer for arrays:

InStr(TypeName(varTest), "()")

The return values cast to Boolean TRUE or FALSE and can be used directly in an IF... THEN clause.

Kludgy, but effective. Note that this detects empty arrays: their typename isn't "empty", it is Empty()

The correct approach is to use the native VBA function VarType(), which reads the numeric type constant. An integer is VarType 2 (vbInteger) and the vbArray constant (8192) is used in a bitwise operation to give 8192 for an array of integers: [vbInteger OR vbArray]

The 'correct' approach fails when you try to wrap this logic in a function, for reasons stated in the comments...

Public Function VariantIsArray(varTest As Variant) As Boolean

' Return TRUE if varTest is array

' FALSE for User-defined types

' Note that all ranges of two or more cells are cast to an array variant

' even when you omit the '.Value' property. All object types that expose

' a default property will pass it into our function's parameter, instead

' of a reference to the object itself. There can be no reliable and self

' -contained IsArray() function in VBA, because you have to run a prior

' test using IsObject() in the calling function.

' What, you read the documentation and believed that IsArray() works? Try

' it on an array of objects, a single-member array, and an empty variant.

VariantIsArray = VarType(varTest) And vbArray

End Function

Using Microsoft Excel to feed batches of files to a command-line utility

2009-01-30T23:25:00.016Z

Overview:

This is a kind of Swiss Army Knife: whenever I need to process batches of files, I pull out this simple application and tweak the code. I don't recommend it as production code - there are far better ways of doing this on a server - but ad-hoc jobs are the daily bread of a desktop developer. You could write it as a script - and a sysadmin would do exactly that - but Excel was the tool to hand when I realised that I had to do this job every week or so.

Highlights for novice VBA coders:

Looping through the files in a folder using VBA.FileSystem.Dir()
Selecting and opening folders with the Office.FileDialog Object
Using the Windows Scripting Host Object Model - wshom.ocx:
- The File System Object - IWshRuntimeLibrary.FileSystemObject
- The Execution Object - IWshRuntimeLibrary.WshExec
- The Shell Object - IWshRuntimeLibrary.WshShell
Reading STDIO, the standard input/output stream of a command-line executable
Reading and logging STERR, the error message stream of a command-line executable.

The background to this...

Processing batches of files... Don't we just love the daily grind of the COBOL era? Except that in the real world, almost every trading and invoicing system has some kind of back-end audit and reconciliation function, separated from the end-to-end streams of XML that you hope are running smoothly in the foreground. These audit systems tend to run on FTP file drops from counterparties - brokers, custodians, banks providing prime brokerage services etc - and they form part of every company's overnight processing.

Mostly, we don't see any of this ('We' as in developers and users: sysadmins see a lot of it). But every now and again, you'll be asked for a one-off job of loading or reprocessing a bunch of files where the regular process has failed, or was never written because someone in the Back Office only does it once a year.

The worst of these jobs consist of feeding files into a command-line executable; this particular example involves decrypting them with pgp.exe - and no, I didn't choose to do it that way, but getting a pgp add-in and transferring the keyring was just too much work. The short version is, every single file in a daily batch of 27 needs a long and fiddly command-line with five parameters, and I've automated the process with a cuddly point-and-click interface.

You can adapt this code to work with any command-line executable, even the good old DOS COPY command if you feel that the exercise will be good for you. Ambitious students can implement a drag-and drop, using controls available in MSForms.2 - please put the code into a comment when you do, so we can all see how you did it: the drag-and-drop events don't quite do what you expect in Excel!

Here's a picture of a spreadsheet used as a form:

The VBA code behind the one and only worksheet:

Feel free to put it in your own userform instead of a worksheet. Also: watch out when you copy-and-paste. I've tested this, but there's always a possibility that Blogger has reformatted a line break or inserted HTML that breaks the VBA syntax.

Option Explicit

' This is a simple batch-processing application: a wrapper for a command-line
' programme that processes all the files in a folder. The example application
' is for batch decryption using pgp.exe, but this can be adapted to almost any
' command-line application, script or shell command.

' This was built into a worksheet; if you prefer, you can put all this code
' into a userform. But watch out for the dependency on named ranges; you'll
' need to recode all this to use Textboxes or Win32 common-dialog controls.

' The following components are assumed to exist and are mandatory:

' Excel Named Ranges:

' SourceFolder
' TargetFolder

' The following components are optional but the code is difficult to understand
' if they are not included:

' MSForms2 CommandButton Objects:

' cmdGo
' cmdGetSourceFolder
' cmdGetTargetFolder
' cmdOpenSource
' cmdOpenTarget

' In order to use this specific example, you will need pgp.exe and an RSA keyring.
' DOS 'copy' would work just as well: the minimum features are that it has Command-
' Line parameters for a source file and an output file.

Private Sub cmdGo_Click()

' The Big Button Marked 'GO'
' This launches the batch process.
' Runs the command-line utility on every matching file in the source folder.

' Creates a log file.

On Error GoTo ErrSub

Const FILE_PATTERN As String = "*.pgp"
Const LOG_FILE As String = "LogFile.txt"
Const ERROR_FILE As String = "Error.txt"
Const KEYRING_NAME As String = ".PRIVATE3"

Dim strCmd As String
Dim strFile As String
Dim strFolder_Target As String
Dim strFolder_Source As String
Dim iResult As Integer
Dim iFile As Integer
Dim iFileCount As Integer
Dim strFileTarget As String
Dim boolError As Boolean

' Help on the Windows Scripting host is available here:
' http://msdn2.microsoft.com/en-us/library/98591fh7.aspx

' Windows Script Host Object Model
' C:\WINDOWS\system32\wshom.ocx

Dim objFSO As IWshRuntimeLibrary.FileSystemObject
Dim oxLogFile As IWshRuntimeLibrary.TextStream
Dim objExec As IWshRuntimeLibrary.WshExec
Dim objShell As IWshRuntimeLibrary.WshShell
Dim objNetwork As IWshRuntimeLibrary.WshNetwork

' Read the user-specified folder paths:
strFolder_Target = ThisWorkbook.Names("TargetFolder").RefersToRange.Value
strFolder_Target = Trim(strFolder_Target)

If Right(strFolder_Target, 1) <> "\" Then

strFolder_Target = strFolder_Target & "\"

End If

'If the folder does not exist, create it:
If Len(Dir(strFolder_Target, vbDirectory)) < 1 Then

MkDir strFolder_Target

End If

strFolder_Source = ThisWorkbook.Names("SourceFolder").RefersToRange.Value
strFolder_Source = Trim(strFolder_Source)

If Right(strFolder_Source, 1) <> "\" Then

strFolder_Source = strFolder_Source & "\"

End If

' Create File system objects:
Set objNetwork = New IWshRuntimeLibrary.WshNetwork
Set objShell = New IWshRuntimeLibrary.WshShell
Set objFSO = New IWshRuntimeLibrary.FileSystemObject

' Create a log file:
Set oxLogFile = objFSO.OpenTextFile(strFolder_Target & "LogFile.txt", ForWriting, True, TristateUseDefault)

oxLogFile.WriteLine Now() & vbTab & "START FOLDER" & vbTab & strFolder_Source

iFileCount = objFSO.GetFolder(strFolder_Source).Files.Count

' Select the first of the source files for your command-line app.
strFile = Dir(strFolder_Source & FILE_PATTERN) ' Yes, it seems odd to use Dir() when there's a file
' system object, but it enumerates files with wildcards

If objFSO.FileExists(strFolder_Target & ERROR_FILE) Then

objFSO.DeleteFile strFolder_Target & ERROR_FILE, True

End If

'Start loop, processing every matching file in the folder...
boolError = False
iFile = 1

Do While Len(strFile) > 1

Application.StatusBar = "Reading file " & iFile & " of " & iFileCount

oxLogFile.WriteLine Now() & vbTab & "START FILE" & vbTab & Chr(34) & strFolder_Source & strFile & Chr(34)

strFileTarget = ""
strFileTarget = strFolder_Target & Left(strFile, Len(strFile) - 4)

If objFSO.FileExists(strFileTarget) Then

On Error Resume Next

objFSO.DeleteFile strFileTarget, True

End If

If objFSO.FileExists(strFileTarget) Then

strFileTarget = strFolder_Target & "Copy_of_ & Left(strFile, Len(strFile) - 4)"

End If

' Concatenate your command-line: use chr(34) instead of playing with nested quote marks!

strCmd = ""
strCmd = strCmd & "pgp.exe -v "
strCmd = strCmd & "--decrypt "
strCmd = strCmd & Chr(34) & strFolder_Source & strFile & Chr(34)
strCmd = strCmd & " --output "
strCmd = strCmd & Chr(34) & strFileTarget & Chr(34)
strCmd = strCmd & " --passphrase "
strCmd = strCmd & Chr(34) & KEYRING_NAME & Chr(34)

iResult = 0
iResult = objShell.Run(strCmd, 0, True)

If iResult <> 0 Then 'Failed run: retry, with logging. ObjExec can see the message stream

oxLogFile.WriteLine "" & vbTab & "RETRY FILE" & vbTab & "FAILED WITH ERROR " & iResult & vbTab & strCmd

Set objExec = objShell.Exec(strCmd)

Do While objExec.Status <= WshRunning

Do Until objExec.StdOut.AtEndOfStream

oxLogFile.WriteLine "" & vbTab & "MESSAGE" & vbTab & objExec.StdOut.ReadLine

Loop

Loop

' No, this isn't redundant.
Do Until objExec.StdOut.AtEndOfStream

oxLogFile.WriteLine "" & vbTab & "MESSAGE" & vbTab & objExec.StdOut.ReadLine

Loop

Do Until objExec.StdErr.AtEndOfStream

boolError = True

oxLogFile.WriteLine "" & vbTab & "ERROR MESSAGE" & vbTab & objExec.StdErr.ReadLine

Loop

End If 'iretry <> 0

Set objExec = Nothing

oxLogFile.WriteLine Now() & vbTab & "END FILE" & vbTab & Chr(34) & strFileTarget & Chr(34)

strFile = Dir
iFile = iFile + 1

Loop

oxLogFile.WriteLine Now() & vbTab & "END FOLDER" & vbTab & objNetwork.ComputerName & vbTab & objNetwork.UserName
oxLogFile.Close

' If the error flag is TRUE, rename the logfile as the error file.
If boolError Then

objFSO.CopyFile strFolder_Target & LOG_FILE, strFolder_Target & ERROR_FILE, True

End If

ExitSub:

Application.StatusBar = False
Application.Cursor = xlDefault
Set oxLogFile = Nothing
Set objExec = Nothing
Set objFSO = Nothing
Set objShell = Nothing
Set objNetwork = Nothing

Exit Sub

ErrSub:

Resume ExitSub

End Sub

Private Sub cmdGetSourceFolder_Click()

' Open a file dialogue enabling the user to create or select a folder.
' Populates the SourceFolder named range if successful

' Recommended icon for this button is the 'folder search' magnifying glass

Dim strFolder_Source As String
Dim objFD As FileDialog
Dim vrtSelectedItem As Variant

Set objFD = Application.FileDialog(msoFileDialogFolderPicker)

strFolder_Source = ThisWorkbook.Names("SourceFolder").RefersToRange.Value

With objFD

.AllowMultiSelect = False
.InitialFileName = strFolder_Source
.Title = "Specify the source folder..."
.InitialView = msoFileDialogViewDetails

If .Show = -1 Then

If .SelectedItems.Count > 0 Then

strFolder_Source = ""
strFolder_Source = .SelectedItems(1)

If strFolder_Source <> "" Then

ThisWorkbook.Names("SourceFolder").RefersToRange.Value = strFolder_Source

End If

End If

End If

End With

End Sub

Private Sub cmdGetTargetFolder_Click()

' Open a file dialogue enabling the user to create or select a folder.
' Populates the TargetFolder named range if successful
' Recommended icon for this button is the 'folder search' magnifying glass

Dim strFolder_Target As String
Dim objFD As FileDialog
Dim vrtSelectedItem As Variant

Set objFD = Application.FileDialog(msoFileDialogFolderPicker)

strFolder_Target = ThisWorkbook.Names("TargetFolder").RefersToRange.Value

With objFD

.AllowMultiSelect = False
.InitialFileName = strFolder_Target
.Title = "Specify the Target folder..."
.InitialView = msoFileDialogViewDetails

If .Show = -1 Then

If .SelectedItems.Count > 0 Then

strFolder_Target = ""
strFolder_Target = .SelectedItems(1)

If strFolder_Target <> "" Then

ThisWorkbook.Names("TargetFolder").RefersToRange.Value = strFolder_Target

End If

End If

End If

End With

End Sub

Private Sub cmdOpenSource_Click()

' Reads the SourceFolder named range.
' Opens a Windows Explorer window displaying the folder and its contents.
' Recommended icon for this button is the standard Windows 'Open Folder'

On Error Resume Next

Dim strCmd As String
Dim strFile As String
Dim strFolder_Source As String

strFolder_Source = ThisWorkbook.Names("SourceFolder").RefersToRange.Value

strCmd = "Explorer " & Chr(34) & strFolder_Source & Chr(34)

Shell strCmd, vbNormalFocus

End Sub

Private Sub cmdOpenTarget_Click()

' Reads the TargetFolder named range.
' Opens a Windows Explorer window displaying the folder and its contents.
' Recommended icon for this button is the standard Windows 'Open Folder'

On Error Resume Next

Dim strCmd As String
Dim strFile As String
Dim strFolder_Target As String

strFolder_Target = ThisWorkbook.Names("TargetFolder").RefersToRange.Value

strCmd = "Explorer " & Chr(34) & strFolder_Target & Chr(34)

Shell strCmd, vbNormalFocus

End Sub

Private Sub RedoAllFolders()

' Redo EVERY folder
' Start with the parent folders specified in source and target
' WARNING - this overwrites everything in the target folders.
' It is inadvisable to provide the users with this function -
' leave it for administrators doing large one-off batches

Dim strFile As String
Dim strFolder_Target As String
Dim strFolder_Source As String

' Help on the Windows Scripting host is available here:
' http://msdn2.microsoft.com/en-us/library/98591fh7.aspx

' Windows Script Host Object Model
' C:\WINDOWS\system32\wshom.ocx

Dim objFSO As IWshRuntimeLibrary.FileSystemObject
Dim objSourceFolder As IWshRuntimeLibrary.Folder
Dim objSourceParentFolder As IWshRuntimeLibrary.Folder
Dim objTargetFolder As IWshRuntimeLibrary.Folder
Dim objTargetParentFolder As IWshRuntimeLibrary.Folder

Set objFSO = New IWshRuntimeLibrary.FileSystemObject

strFolder_Target = ThisWorkbook.Names("TargetFolder").RefersToRange.Value
strFolder_Target = Trim(strFolder_Target)

If Right(strFolder_Target, 1) <> "\" Then

strFolder_Target = strFolder_Target & "\"

End If

'If the folder does not exist, create it:
If Not objFSO.FolderExists(strFolder_Target) Then

MkDir strFolder_Target

End If

If Not objFSO.FolderExists(strFolder_Target) Then

MsgBox "Target folder does not exist and cannot be created: " & vbCrLf & vbCrLf & strFolder_Target, vbCritical, "No target folder..."
GoTo ExitSub

End If

Set objTargetParentFolder = objFSO.GetFolder(strFolder_Target)

strFolder_Source = ThisWorkbook.Names("SourceFolder").RefersToRange.Value
strFolder_Source = Trim(strFolder_Source)

If Right(strFolder_Source, 1) <> "\" Then

strFolder_Source = strFolder_Source & "\"

End If

If Not objFSO.FolderExists(strFolder_Source) Then

MsgBox "The source folder does not exist: " & vbCrLf & vbCrLf & strFolder_Target, vbCritical, "No target folder..."
GoTo ExitSub

End If

Application.Cursor = xlWait

Set objSourceParentFolder = objFSO.GetFolder(strFolder_Source)

For Each objSourceFolder In objSourceParentFolder.SubFolders

ThisWorkbook.Names("SourceFolder").RefersToRange.Value = objSourceFolder.Path

strFolder_Target = objFSO.BuildPath(objTargetParentFolder.Path, objSourceFolder.Name)

ThisWorkbook.Names("TargetFolder").RefersToRange.Value = strFolder_Target

cmdGo_Click

Next objSourceFolder

ExitSub:

Application.Cursor = xlDefault
Set objSourceParentFolder = Nothing
Set objSourceFolder = Nothing
Set objFSO = Nothing

Exit Sub

ErrSub:

Resume ExitSub

End Sub

A few observations...

Are there better ways of doing this? Yes, definitely. There are scripting mavens out there who could can tap out a three-line shell script that'll do the lot in seconds... But I used the tools I had to hand; you're probably not the wizard you thought you were, and will find out after an hour of fruitless debugging; and unfamiliar command-line executables with finnicky switches need to be wrapped in a way that allows you to see, clearly and plainly, exactly what it is that you're doing. Note, also, that the error-logger writes out the command line, verbatim - a habit I would urge all novice developers to adopt today, because knowing what your application did is the key to effective testing.

I've used a separate logfile in this application but, this being Excel, I might've done better to write it all out onto a worksheet. I mean, it's already open and running, why not use it? Hindsight's a wonderful thing.

Meanwhile, feel free to offer examples of other tasks that you wrapped up in Excel.

Introduction to Excellerando

2009-01-30T22:50:00.005Z

Welcome to Excellerando, a blog devoted to arcane VBA-Geekery, mostly in Microsoft Excel.

I don't claim to be a definitive source on the subject (that would be the book Professional Excel Development by Stephen Bullen, Rob Bovey and John Green). Instead, you'll get odd code scraps, fixes to uncommon problems, and usable code that saves reinventing the wheel.

Much of it will have a financial and banking perspective, because that's what I've spent the last ten years doing for a living: bashing out spreadsheets and add-ins for traders, analysts, risk managers and anyone else who asks in banks and hedge funds.

Comments are welcome; questions will be answered - eventually - but your first port of call for any Excel question should be the Usenet boards or a quick search through Daily Dose of Excel, a blog that you really should be reading every day if you're programming with Excel for a living.

Meanwhile, sit back, relax, and reflect upon the knowledge that the worst job you've ever been asked to do in Excel has surely been done already by someone else, and the source code's out there. Or, quite possibly, here.