VBA: файл DateTime, летнее время и соответствие SOX - PullRequest
Новая
       1

VBA: файл DateTime, летнее время и соответствие SOX

0 голосов
/ 04 декабря 2018

Наши аудиторы соответствия Sarbanes-Oxley запросили процесс, чтобы проверить, какие файлы меняются в нашей системе, поэтому я написал быстрый сценарий VBA в Excel, который просматривает дерево каталогов, получает путь, последний измененный штамп даты и времени и размер,Я сохранил все это в CSV месяц назад и снова запустил в этом месяце.Затем я сравниваю снимок прошлого месяца со снимком этого месяца, создав два словаря.Ключом к словарям является путь к файлу и имя файла, а значение - это массив DateTime и Size.Затем я перебираю словари, чтобы сравнить их.Если файл существует в старом снимке, но не в новом, я знаю, что он был удален.Если он существует в новом снимке, но не в старом, он был создан, и если файл существует в обоих, но значения DateTime или Size отличаются, я знаю, что он был изменен.

Проблема в том, что переход на летнее время вступил в силу между двумя запусками, и теперь все штампы DateTime визуально отличаются на рабочем листе на час.Я подчеркиваю визуально, потому что мой код говорит, что два файла одинаковы, и я знаю, что эти два файла одинаковы, но Excel отображает штампы DateTime как отличающиеся на 1 час. Я знаю, что это не проблема Excel .Это хорошо документированная "особенность" Win32 API.

Мой вопрос заключается в том, как мне (или мне) поступить с не-компьютерным сокс-аудитором, сравнивающим список прошлых файлов с текущим списком файлов и видящим, что все DateTimes предположительно неизмененных файлов различаются на один час?Этот инструмент используется несколькими дочерними компаниями и будет использоваться в течение неопределенного периода времени.Возможно, он все еще будет использоваться, когда часы наступят на час следующей весной.Если я намерен программно настроить метки DateTime таким образом, чтобы файлы имели одинаковую дату и время на листе (а не только одно и то же время UTC в сравниваемых данных файла), как бы я обнаружил, действует ли DST или когда?

Я не знаю, действительно ли это нужно для моего вопроса, но вот текущий код.Первый фрагмент кода помещается в рабочий лист VBA с двумя кнопками ActiveX.Поместите второй набор кода в модуль и убедитесь, что в вашей книге 3 листа: Текущий снимок, Старый снимок и Изменения.

Лист1 

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

1 Ответ

0 голосов
/ 04 декабря 2018

Если вы храните все время как (например) GMT, то это не будет проблемой.

См., Например,

http://www.excelfox.com/forum/showthread.php/542-Get-standard-GMT-time-from-the-system-using-vba

.

РЕДАКТИРОВАТЬ: вы также можете рассмотреть возможность добавления хеша MD5 для каждого файла на лист.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...