Our Sarbanes-Oxley compliance auditors asked for a process to verify which files were changing in our system, so I wrote a quick VBA script in Excel to recurse through a directory tree, get the path, last modified datetime stamp, and size. I saved this all to a CSV a month ago, and ran it again this month. I then compare last month's snapshot to this month's snapshot by creating two dictionaries. The key to the dictionaries is the file path and filename, and the value is an array of DateTime and Size. Then I loop through the dictionaries to compare them. If a file exists in the old snapshot but not the new, I know it was deleted. If it exists in the new snapshot but not the old, it was created, and if the file exists in both but the DateTime or Size values are different I know it was modified.
The issue is that Daylight Savings went into effect between the two runs, and now all the DateTime stamps visually differ on the worksheet by an hour. I stress visually because my code says the two files are the same, and I know the two files are the same, but Excel is displaying the DateTime stamps as being different by 1 hour. I know this is not an Excel issue. It is a well documented "feature" of the Win32 API.
My question is how do I (or should I) deal with a non-computer savvy SOX auditor comparing a past file listing to a present file listing and seeing all the DateTimes of supposedly unchanged files being different by one hour? This tool is being used by several sister companies and will continue to be used for an indeterminate length of time. It is possible it may still be in use when the clocks move ahead an hour next Spring. If I intend to programatically adjust DateTime stamps so that the files appear to have the same Date an Time on the worksheet (and not just the same UTC time in the compared file data), how would I detect if or when DST is in effect?
I don't know that its really needed for my question, but here is the current code. The first bit of code goes in a VBA Worksheet with 2 ActiveX buttons. Put the second set of code in a module and make sure your workbook has 3 worksheets: Current Snapshot, Old Snapshot, and Changes.
Sheet1
Option Explicit
Private Sub cmdTakeSnapshot_Click()
Dim strStartFolder As String
Dim SaveChoice As Long
strStartFolder = selectFolder
If strStartFolder <> "" Then
Application.Cursor = xlWait
Application.ScreenUpdating = False
takeSnapshot strStartFolder
Application.ScreenUpdating = True
Application.Cursor = xlDefault
SaveChoice = MsgBox("Snapshot complete." & vbNewLine & "Click OK to Save.", vbOKCancel, "Finished")
If SaveChoice = 1 Then saveSnapshot
ThisWorkbook.Worksheets("Current Snapshot").Activate
Else
MsgBox "No folder selected...exiting", vbOKOnly, "Cancelled"
End If
End Sub
Private Sub cmdCompareSnapshots_Click()
Dim FSO As Object
Dim strStartFolder As String
Dim strOldSnapshot As String
Dim SaveChoice As Long
strOldSnapshot = selectFile
If strOldSnapshot <> "" Then
Application.Cursor = xlWait
Application.ScreenUpdating = False
loadSnapshot strOldSnapshot
Application.ScreenUpdating = True
Application.Cursor = xlDefault
End If
strStartFolder = selectFolder
If strStartFolder <> "" Then
Application.Cursor = xlWait
Application.ScreenUpdating = False
takeSnapshot strStartFolder
Application.ScreenUpdating = True
Application.Cursor = xlDefault
SaveChoice = MsgBox("New snapshot complete." & vbNewLine & "Click OK to Save.", vbOKCancel, "Finished")
If SaveChoice = 1 Then saveSnapshot
End If
ThisWorkbook.Worksheets("Changes").Activate
Application.Cursor = xlWait
Application.ScreenUpdating = False
compareSnapshots
Application.ScreenUpdating = True
Application.Cursor = xlDefault
ThisWorkbook.Worksheets("Changes").Activate
End Sub
Module1
Option Explicit
Public Sub takeSnapshot(sFolder As String)
Dim FSO As Object 'FileSystemObject
Dim oFolder As Object 'Folder
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(sFolder)
ThisWorkbook.Worksheets("Current Snapshot").UsedRange.Delete
ThisWorkbook.Worksheets("Current Snapshot").Range("A1:D1") = Array("Last Modified", "Size", "File Name", "Folder")
ThisWorkbook.Worksheets("Current Snapshot").Range("A1:D1").Font.Bold = True
ThisWorkbook.Worksheets("Current Snapshot").Columns(1).NumberFormat = "mm/dd/yyyy h:mm:ss"
listFolders oFolder
ThisWorkbook.Worksheets("Current Snapshot").Columns.AutoFit
Set FSO = Nothing
Set oFolder = Nothing
End Sub
Public Sub loadSnapshot(sFile As String)
Dim sh As Worksheet
Dim qt As QueryTable
Set sh = ThisWorkbook.Sheets("Old Snapshot")
For Each qt In sh.QueryTables
qt.SaveData = False
qt.Delete
Next
sh.UsedRange.Delete
With sh.QueryTables.Add(Connection:="TEXT;" & sFile, Destination:=sh.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
End With
For Each qt In sh.QueryTables
qt.SaveData = False
qt.Delete
Next
sh.Range("A1:D1").Font.Bold = True
sh.Columns(1).NumberFormat = "mm/dd/yyyy h:mm:ss"
sh.Columns.AutoFit
End Sub
Public Sub compareSnapshots()
Dim sh As Worksheet
Dim objOld As Object, objNew As Object, objChanged As Object
Dim r As Long, lastRow As Long
Dim sKey As String, aValue(1) As String, sPath As String, sFilename As String
Dim vItem As Variant
Set objOld = CreateObject("Scripting.Dictionary")
Set objNew = CreateObject("Scripting.Dictionary")
Set objChanged = CreateObject("Scripting.Dictionary")
Set sh = ThisWorkbook.Sheets("Old Snapshot")
lastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
For r = 2 To lastRow
If sh.Cells(r, 4) <> "" Then
sKey = sh.Cells(r, 4).value & sh.Cells(r, 3).value
aValue(0) = sh.Cells(r, 1).value
aValue(1) = sh.Cells(r, 2).value
If Not objOld.Exists(sKey) Then
objOld.Add sKey, aValue
End If
End If
Next
Set sh = ThisWorkbook.Sheets("Current Snapshot")
lastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
For r = 2 To lastRow
If sh.Cells(r, 4) <> "" Then
sKey = sh.Cells(r, 4).value & sh.Cells(r, 3).value
aValue(0) = sh.Cells(r, 1).value
aValue(1) = sh.Cells(r, 2).value
If Not objNew.Exists(sKey) Then
objNew.Add sKey, aValue
End If
End If
Next
Set sh = ThisWorkbook.Sheets("Changes")
sh.UsedRange.Delete
r = 2
For Each vItem In objNew.Keys
If objOld.Exists(vItem) Then
Dim vTemp As Variant
If objOld(vItem)(0) <> objNew(vItem)(0) Then
vTemp = Split(vItem, "\", -1, vbBinaryCompare)
sFilename = vTemp(UBound(vTemp))
sPath = Replace(vItem, sFilename, "", 1, -1, vbBinaryCompare)
sh.Cells(1, 1) = "Changed Files:"
sh.Cells(r, 2) = sPath
sh.Cells(r, 3) = sFilename
sh.Cells(r, 4) = objOld(vItem)(0)
sh.Cells(r, 5) = objOld(vItem)(1)
sh.Cells(r + 1, 4) = objNew(vItem)(0)
sh.Cells(r + 1, 5) = objNew(vItem)(1)
r = r + 2
ElseIf objOld(vItem)(1) <> objNew(vItem)(1) Then
vTemp = Split(vItem, "\", -1, vbBinaryCompare)
sFilename = vTemp(UBound(vTemp))
sPath = Replace(vItem, sFilename, "", 1, -1, vbBinaryCompare)
sh.Cells(1, 1) = "Changed Files:"
sh.Cells(r, 2) = sPath
sh.Cells(r, 3) = sFilename
sh.Cells(r, 4) = objOld(vItem)(0)
sh.Cells(r, 5) = objOld(vItem)(1)
sh.Cells(r + 1, 4) = objNew(vItem)(0)
sh.Cells(r + 1, 5) = objNew(vItem)(1)
r = r + 2
End If
objOld.Remove vItem
objNew.Remove vItem
End If
Next
If objOld.Count > 0 Then
sh.Cells(r, 1) = "Deleted Files:"
r = r + 1
For Each vItem In objOld.Keys
Dim vTempArray As Variant
vTempArray = Split(vItem, "\", -1, vbBinaryCompare)
sFilename = vTempArray(UBound(vTempArray))
sPath = Replace(vItem, sFilename, "", 1, -1, vbBinaryCompare)
sh.Cells(r, 2) = sPath
sh.Cells(r, 3) = sFilename
sh.Cells(r, 4) = objOld(vItem)(0)
sh.Cells(r, 5) = objOld(vItem)(1)
r = r + 1
Next
End If
If objNew.Count > 0 Then
sh.Cells(r, 1) = "Added Files:"
r = r + 1
For Each vItem In objNew.Keys
Dim vTempArray2 As Variant
vTempArray2 = Split(vItem, "\", -1, vbBinaryCompare)
sFilename = vTempArray2(UBound(vTempArray2))
sPath = Replace(vItem, sFilename, "", 1, -1, vbBinaryCompare)
sh.Cells(1, 1) = "Changed Files:"
sh.Cells(r, 2) = sPath
sh.Cells(r, 3) = sFilename
sh.Cells(r + 1, 4) = objNew(vItem)(0)
sh.Cells(r + 1, 5) = objNew(vItem)(1)
r = r + 1
Next
End If
sh.Columns(4).NumberFormat = "mm/dd/yyyy h:mm:ss"
sh.Columns.AutoFit
End Sub
Public Function listFolders(fldStart As Object)
Dim oFolder As Object 'Folder
Dim sh As Worksheet
Dim r As Long
Set sh = ThisWorkbook.Worksheets("Current Snapshot")
For Each oFolder In fldStart.SubFolders
r = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
r = r + 1
sh.Cells(r, 1) = oFolder.DateLastModified
sh.Cells(r, 2) = "<DIR>"
sh.Cells(r, 3) = oFolder.Name
listFiles oFolder
listFolders oFolder
DoEvents
Next
End Function
Private Function listFiles(oFolder As Object)
Dim oFile As Object 'File
Dim sh As Worksheet
Dim DirSize As Double, Filecount As Double
Dim r As Long
On Error GoTo PermissionDenied
Set sh = ThisWorkbook.Worksheets("Current Snapshot")
r = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
For Each oFile In oFolder.Files
r = r + 1
sh.Cells(r, 1) = oFile.DateLastModified
sh.Cells(r, 2) = oFile.Size
sh.Cells(r, 3) = oFile.Name
sh.Cells(r, 4) = oFolder.Path
DoEvents
Next
Exit Function
PermissionDenied:
sh.Cells(r, 1) = Now()
sh.Cells(r, 2) = "#N/A"
sh.Cells(r, 3) = "Permission Denied on Folder:"
sh.Cells(r, 4) = oFolder.Path
End Function
Public Function selectFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
selectFolder = sItem
Set fldr = Nothing
End Function
Public Function selectFile() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFilePicker)
With fldr
.Title = "Select a Snapshot"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
selectFile = sItem
Set fldr = Nothing
End Function
Public Function saveSnapshot()
Dim sFolderPath As String
sFolderPath = selectFolder
sFolderPath = sFolderPath & "\"
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Current Snapshot").Copy
ActiveWorkbook.SaveAs Filename:=sFolderPath & Format(Date, "MM-dd-yyyy") & " Snapshot", FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Function
