NonSoft

VBSやVBAでフォルダの変更を監視する方法

 ち〜な〜み〜に〜

VBS(VB SCRIPT/WSH)やVBAで手軽にフォルダの変更を監視する方法をご紹介します。

フォルダ監視とは、フォルダ内のファイルに対し更新日時の変更やファイルの追加、削除を監視し、
通知(メッセージ表示、アイコン点滅、メール送信)や指定プログラム実行をする事を意味します。

このサンプルでは変更があったファイルのPATHを通知(メッセージ表示)します。

フォルダ監視関係のその他のサンプルソースはこちらです。
VBSやVBAでファイルの変更を監視する方法
VBSやVBAでファイル比較し差分を出力する方法
VBSやVBAでフォルダ比較し差分を出力する方法

フォルダ監視(ファイル監視)関係のその他のツールやサンプルソースはこちらです。
ファイル監視／フォルダ監視(ツール＆サンプル)
ファイル比較／フォルダ比較(ツール＆サンプル)
★フォルダ監視サンプルソース 
' --------------------------------------------------------------------
' VBAの時はSleepのAPI宣言(Declare)が必要
' Private Declare Sub Sleep Lib "kernel32" (ByVal dwMs As Long)
' --------------------------------------------------------------------
' 監視するフォルダの設定
fol_path = "D:\Temp\test"

' (変更前)フォルダ内のファイル一覧(更新日時付き)の取得
Redim path_list1(0)
GetFDate fol_path, path_list1

'Dim path_list0() ' VBAの時に必要
path_list0 = path_list1

Do
    WScript.Sleep(1000)   ' VBSの時
    'Sleep 1000: DoEvents ' VBAの時

    ' (変更後)フォルダ内のファイル一覧(更新日時付き)の取得
    Redim path_list2(0)
    GetFDate fol_path, path_list2

    ' 変更前後のファイル一覧(更新日時付き)の比較
    Redim comp_list(0)
    FComp path_list0, path_list2, comp_list

    ' 比較結果表示
    For i = 1 To Ubound(comp_list)
        MsgBox comp_list(i)
    Next

    ' 変更後を変更前として設定
    path_list0 = path_list2
Loop
' --------------------------------------------------------------------

' フォルダ内のファイル一覧(更新日時付き)の取得------------------------
Public Sub GetFDate(ByVal fol_path, ByRef path_list())
    Set fso = CreateObject("Scripting.FileSystemObject")

    For Each f In fso.GetFolder(fol_path).files
        ReDim Preserve path_list(UBound(path_list) + 1)
        path_list(UBound(path_list)) = _
            f.path & vbTab & fso.GetFile(f.path).DateLastModified
    Next

    For Each f In fso.GetFolder(fol_path).SubFolders
        GetFDate f.path, path_list
    Next

    Set fso = Nothing
End Sub
' --------------------------------------------------------------------

' ファイル一覧(更新日時付き)の比較------------------------------------
Public Sub FComp(ByRef ls1(), ByRef ls2(), ByRef comp_list())
    p1 = 1
    p2 = 1
    Do
        If p1 > Ubound(ls1) And p2 > Ubound(ls2) Then
            Exit Do
        End If

        fd1 = ""
        fd2 = ""
        If p1 <= Ubound(ls1) Then
            fd1 = Split(ls1(p1), vbTab)
        End If
        If p2 <= Ubound(ls2) Then
            fd2 = Split(ls2(p2), vbTab)
        End If

        If IsArray(fd1) = True And IsArray(fd2) = True Then
            fn1 = LCase(fd1(0))
            fn2 = LCase(fd2(0))
            If fn1 = fn2 Then
                If fd1(1) = fd2(1) Then
                ElseIf fd1(1) <> fd2(1) Then
                    ReDim Preserve comp_list(UBound(comp_list) + 1)
                    comp_list(UBound(comp_list)) = "(Mod)" & fd1(0)
                End If
                p1 = p1 +1
                p2 = p2 +1
            ElseIf fn1 < fn2 Then
                ReDim Preserve comp_list(UBound(comp_list) + 1)
                comp_list(UBound(comp_list)) = "(Del)" & fd1(0)
                p1 = p1 +1
            ElseIf fn1 > fn2 Then
                ReDim Preserve comp_list(UBound(comp_list) + 1)
                comp_list(UBound(comp_list)) = "(Add)" & fd2(0)
                p2 = p2 +1
            End If
        ElseIf IsArray(fd1) = True And IsArray(fd2) = False Then
            ReDim Preserve comp_list(UBound(comp_list) + 1)
            comp_list(UBound(comp_list)) = "(Del)" & fd1(0)
            p1 = p1 +1
        ElseIf IsArray(fd1) = False And IsArray(fd2) = True Then
            ReDim Preserve comp_list(UBound(comp_list) + 1)
            comp_list(UBound(comp_list)) = "(Add)" & fd2(0)
            p2 = p2 +1
        Else
            p1 = p1 +1
            p2 = p2 +1
        End If
    Loop
End Sub
' --------------------------------------------------------------------