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.