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

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

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

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

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.