フォルダ内で起こった変更を検知

====== fm_FileChange ======
Option Compare Database
Option Explicit

Const cTestFile = "#Test.txt"
Const cTestFolder = "#TestFolder"
Dim hFILE_NOTIFY_CHANGE_FILE_NAME As Long   'ファイル名の変更
Dim hFILE_NOTIFY_CHANGE_DIR_NAME As Long    'ディレクトリ名の変更
Dim hFILE_NOTIFY_CHANGE_ATTRIBUTES As Long  '属性の変更
Dim hFILE_NOTIFY_CHANGE_SIZE As Long        'ファイルのサイズの変更
Dim hFILE_NOTIFY_CHANGE_LAST_WRITE As Long 'ファイルの最終書き込み時刻の変更
Dim hFILE_NOTIFY_CHANGE_SECURITY As Long    'セキュリティ記述子の変更

Dim WinDir As String
Dim f As Integer
Dim wAttr As Long, rtn As Long

'ファイル名の変更
Private Sub cmd_FILE_NOTIFY_CHANGE_FILE_NAME_Click()
    MsgBox WinDir & " 内に " & cTestFile & " の名前のファイルを作成します。" & vbCr & "このファイルはフォームを閉じるときに削除します。"
    
    On Error Resume Next
    Kill WinDir & "\" & cTestFile
    
    f = FreeFile
    Open WinDir & "\" & cTestFile For Output As #f
    Close #f
    Me!cmd_FILE_NOTIFY_CHANGE_ATTRIBUTES.Enabled = True
    Me!cmd_FILE_NOTIFY_CHANGE_SIZE.Enabled = True
    Me!cmd_FILE_NOTIFY_CHANGE_LAST_WRITE.Enabled = True
End Sub

'ディレクトリ名の変更
Private Sub cmd_FILE_NOTIFY_CHANGE_DIR_NAME_Click()
    MsgBox WinDir & " 内に " & cTestFolder & " の名前のフォルダを作成します。" & vbCr _
            & "このフォルダはフォームを閉じるときに削除します。" _
            & "フォルダの作成は１回しかできません。"
    
    MkDir WinDir & "\" & cTestFolder
    Me!cmd_Find.SetFocus
    Me!cmd_FILE_NOTIFY_CHANGE_DIR_NAME.Enabled = False
End Sub

'属性の変更
Private Sub cmd_FILE_NOTIFY_CHANGE_ATTRIBUTES_Click()
    wAttr = GetAttr(WinDir & "\" & cTestFile)
    MsgBox WinDir & "\" & cTestFile & " のファイル属性は &H" & Hex$(wAttr) & "ファイル属性を読み取り専用に設定します。"
    rtn = SetFileAttributes(WinDir & "\" & cTestFile, vbReadOnly + vbHidden)
End Sub

'ファイルのサイズの変更
Private Sub cmd_FILE_NOTIFY_CHANGE_SIZE_Click()
    '変更を加えるファイルの属性を退避
    wAttr = GetAttr(WinDir & "\" & cTestFile)
    
    '変更を加えるファイルの属性をvbNormalに設定
    rtn = SetFileAttributes(WinDir & "\" & cTestFile, vbNormal)
    
    f = FreeFile
    Open WinDir & "\" & cTestFile For Append As #f
    Print #f, "Loadsystem"
    Close #f
    
    '変更を加えたファイルの属性を戻す
    rtn = SetFileAttributes(WinDir & "\" & cTestFile, wAttr)
End Sub

'ファイルの最終書き込み時刻の変更
Private Sub cmd_FILE_NOTIFY_CHANGE_LAST_WRITE_Click()
    Dim wDateTime As Date
    
    MsgBox WinDir & "\" & cTestFile & " の最終書き込み時刻を昨年の今日に変更します。"
    wDateTime = Now()
    wDateTime = DateAdd("y", -1, wDateTime)
    'LsSetFileTimeは「Accessで使えるWindows API サンプル20」を参照してください
    LsSetFileTime WinDir & "\" & cTestFile, wDateTime
End Sub

Private Sub cmd_Find_Click()
    Dim rc As Long, flg As Boolean
    
    'ファイル名の変更とディレクトリ名の変更を検知するには論理和を使います
    'rc = WaitForSingleObject(hFILE_NOTIFY_CHANGE_FILE_NAME Or hFILE_NOTIFY_CHANGE_DIR_NAME, 100)
    
    
    'ファイル名の変更
    rc = WaitForSingleObject(hFILE_NOTIFY_CHANGE_FILE_NAME, 100)
    If rc = 0 Then
        MsgBox "ファイル名の変更がありました"
        flg = True
        rc = FindNextChangeNotification(hFILE_NOTIFY_CHANGE_FILE_NAME)
    End If
    
    'ディレクトリ名の変更
    rc = WaitForSingleObject(hFILE_NOTIFY_CHANGE_DIR_NAME, 100)
    If rc = 0 Then
        MsgBox "'ディレクトリ名の変更がありました"
        flg = True
        rc = FindNextChangeNotification(hFILE_NOTIFY_CHANGE_DIR_NAME)
    End If
    
    '属性の変更
    rc = WaitForSingleObject(hFILE_NOTIFY_CHANGE_ATTRIBUTES, 100)
    If rc = 0 Then
        MsgBox "'属性の変更がありました"
        flg = True
        rc = FindNextChangeNotification(hFILE_NOTIFY_CHANGE_ATTRIBUTES)
    End If
    
    'ファイルのサイズの変更
    rc = WaitForSingleObject(hFILE_NOTIFY_CHANGE_SIZE, 100)
    If rc = 0 Then
        MsgBox "ファイルのサイズの変更がありました"
        flg = True
        rc = FindNextChangeNotification(hFILE_NOTIFY_CHANGE_SIZE)
    End If
    
    'ファイルの最終書き込み時刻の変更
    rc = WaitForSingleObject(hFILE_NOTIFY_CHANGE_LAST_WRITE, 100)
    If rc = 0 Then
        MsgBox "ファイルの最終書き込み時刻の変更がありました"
        flg = True
        rc = FindNextChangeNotification(hFILE_NOTIFY_CHANGE_LAST_WRITE)
    End If
    
    'セキュリティ記述子の変更
    rc = WaitForSingleObject(hFILE_NOTIFY_CHANGE_SECURITY, 100)
    If rc = 0 Then
        MsgBox "セキュリティ記述子の変更がありました"
        flg = True
        rc = FindNextChangeNotification(hFILE_NOTIFY_CHANGE_SECURITY)
    End If
    
    If flg = 0 Then
        MsgBox "検知できませんでした"
    End If
End Sub

Private Sub Form_Close()
    '通知ハンドルを開放
    Dim rc As Long
    
    'ファイル名の変更
    If hFILE_NOTIFY_CHANGE_FILE_NAME > 0 Then
        rc = FindCloseChangeNotification(hFILE_NOTIFY_CHANGE_FILE_NAME)
    End If
    
    'ディレクトリ名の変更
    If hFILE_NOTIFY_CHANGE_DIR_NAME > 0 Then
        rc = FindCloseChangeNotification(hFILE_NOTIFY_CHANGE_DIR_NAME)
    End If
    
    '属性の変更
    If hFILE_NOTIFY_CHANGE_ATTRIBUTES > 0 Then
        rc = FindCloseChangeNotification(hFILE_NOTIFY_CHANGE_ATTRIBUTES)
    End If
    
    'ファイルのサイズの変更
    If hFILE_NOTIFY_CHANGE_SIZE > 0 Then
        rc = FindCloseChangeNotification(hFILE_NOTIFY_CHANGE_SIZE)
    End If
    
    'ファイルの最終書き込み時刻の変更
    If hFILE_NOTIFY_CHANGE_LAST_WRITE > 0 Then
        rc = FindCloseChangeNotification(hFILE_NOTIFY_CHANGE_LAST_WRITE)
    End If
    
    'セキュリティ記述子の変更
    If hFILE_NOTIFY_CHANGE_SECURITY > 0 Then
        rc = FindCloseChangeNotification(hFILE_NOTIFY_CHANGE_SECURITY)
    End If
    
    On Error Resume Next
    Kill WinDir & "\" & cTestFile
    RmDir WinDir & "\" & cTestFolder
End Sub

Private Sub Form_Open(Cancel As Integer)
    
    WinDir = Environ("WinDir")
    '通知オブジェクトのハンドルを取得
    
    'ファイル名の変更
    hFILE_NOTIFY_CHANGE_FILE_NAME = FindFirstChangeNotification(WinDir, 0, FILE_NOTIFY_CHANGE_FILE_NAME)
    
    'ディレクトリ名の変更
    hFILE_NOTIFY_CHANGE_DIR_NAME = FindFirstChangeNotification(WinDir, 0, FILE_NOTIFY_CHANGE_DIR_NAME)
    
    '属性の変更
    hFILE_NOTIFY_CHANGE_ATTRIBUTES = FindFirstChangeNotification(WinDir, 0, FILE_NOTIFY_CHANGE_ATTRIBUTES)
    
    'ファイルのサイズの変更
    hFILE_NOTIFY_CHANGE_SIZE = FindFirstChangeNotification(WinDir, 0, FILE_NOTIFY_CHANGE_SIZE)
    
    'ファイルの最終書き込み時刻の変更
    hFILE_NOTIFY_CHANGE_LAST_WRITE = FindFirstChangeNotification(WinDir, 0, FILE_NOTIFY_CHANGE_LAST_WRITE)
    
    'セキュリティ記述子の変更
    hFILE_NOTIFY_CHANGE_SECURITY = FindFirstChangeNotification(WinDir, 0, FILE_NOTIFY_CHANGE_SECURITY)
End Sub


====== api_FileChange ======
Option Compare Database
Option Explicit

Public Const FILE_ATTRIBUTE_ARCHIVE = &H20      'ｱｰｶｲﾌﾞ属性
Public Const FILE_ATTRIBUTE_COMPRESSED = &H800  '
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10    'ﾃﾞｨﾚｸﾄﾘ属性
Public Const FILE_ATTRIBUTE_HIDDEN = &H2        '隠しﾌｧｲﾙ属性
Public Const FILE_ATTRIBUTE_NORMAL = &H80       'ﾌｧｲﾙ属性をもたない
Public Const FILE_ATTRIBUTE_READONLY = &H1      '読み込み専用属性
Public Const FILE_ATTRIBUTE_SYSTEM = &H4        'ｼｽﾃﾑﾌｧｲﾙ属性
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100   '

Public Const GENERIC_READ = &H80000000          '読み込みモード
Public Const GENERIC_WRITE = &H40000000         '書き込みモード
Public Const OPEN_EXISTING = 3                  'ファイルをオープンする。
Public Const OPEN_ALWAYS = 4                    'ファイルがあれば、ファイルをオープンする。

Type FILETIME
    dwLowDateTime As Long  '下位32bit
    dwHighDateTime As Long '上位32bit
End Type

Type SYSTEMTIME
    wYear As Integer         '現在の年
    wMonth As Integer        '月(1月=1, 2月=2)
    wDayOfWeek As Integer    '曜日(日曜=0, 月曜=1)
    wDay As Integer          '日
    wHour As Integer         '時
    wMinute As Integer       '分
    wSecond As Integer       '秒
    wMilliseconds As Integer 'ﾐﾘ秒
End Type

'ファイルハンドル取得
Declare Function CreateFileLong Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
'ハンドル開放
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'ファイルタイム取得
Declare Function GetFileTime Lib "kernel32" (ByVal hFile&, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
'ファイルタイムをローカルタイムに変換
Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
'ローカルタイムをシステムタイムに変換
Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
'システムタイムをローカルファイルタイムに変換
Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long
'ローカルファイルタイムをファイルタイムに変換
Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
'最後に更新した日時を変更
Declare Function SetFileTimeLong Lib "kernel32" Alias "SetFileTime" (ByVal hFile&, ByVal lpCreationTime As Long, ByVal lpLastAccessTime As Long, lpLastWriteTime As FILETIME) As Long

'WindowsTempPathを取得
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nSize As Long, ByVal lpBuffer As String) As Long

Sub LsGetFileTime(TempFile As String, 作成日 As Date, 最終アクセス日 As Date, 最終更新日 As Date)
    'TempFile に渡されたファイルの日付情報を返します。
    Dim hFile As Long, RtnCd As Long
    Dim lpCreationTime As FILETIME
    Dim lpLastAccessTime As FILETIME
    Dim lpLastWriteTime As FILETIME
    Dim lpLocalFileTime As FILETIME
    Dim lpSystemTime As SYSTEMTIME
    Dim wDateTime As Date
    
    'ファイルハンドル取得
    hFile = CreateFileLong(TempFile, GENERIC_READ, 0, 0, OPEN_EXISTING, FILE_ATTRIBUTE_ARCHIVE, 0)
    
    'ファイルタイム取得(作成日,最終アクセス日,最終更新日)
    RtnCd = GetFileTime(hFile, lpCreationTime, lpLastAccessTime, lpLastWriteTime)
    
    'ハンドル開放
    RtnCd = CloseHandle(hFile)
    
    'ファイルタイムをローカルタイムに変換
    RtnCd = FileTimeToLocalFileTime(lpCreationTime, lpLocalFileTime)
    GoSub Conv
    作成日 = wDateTime
    
    '最終アクセス日のファイルタイムをローカルタイムに変換
    RtnCd = FileTimeToLocalFileTime(lpLastAccessTime, lpLocalFileTime)
    GoSub Conv
    最終アクセス日 = wDateTime
    
    '最終更新日のファイルタイムをローカルタイムに変換
    RtnCd = FileTimeToLocalFileTime(lpLastWriteTime, lpLocalFileTime)
    GoSub Conv
    最終更新日 = wDateTime
Exit Sub

Conv:
    'ローカルタイムをシステムタイムに変換
    RtnCd = FileTimeToSystemTime(lpLocalFileTime, lpSystemTime)

    With lpSystemTime
        wDateTime = Format(.wYear & "/" & .wMonth & "/" & .wDay & " " & .wHour & ":" & .wMinute & ":" & .wSecond, "yyyy/mm/dd hh:nn:ss")
    End With
Return
End Sub

Sub LsSetFileTime(TempFile As String, wDateTime As Date)
    'TempFile に渡されたファイルの最終更新日を、wDateTimeに設定します。
    Dim RtnCd As Long, hFile As Long
    Dim lpCreationTime As FILETIME
    Dim lpLastAccessTime As FILETIME
    Dim lpLastWriteTime As FILETIME
    Dim lpLocalFileTime As FILETIME
    Dim lpSystemTime As SYSTEMTIME
    
    '設定する日時をセット
    With lpSystemTime
        .wYear = Year(wDateTime)
        .wMonth = Month(wDateTime)
        .wDay = Day(wDateTime)
        .wHour = Hour(wDateTime)
        .wMinute = Minute(wDateTime)
        .wSecond = Second(wDateTime)
    End With
    
    'システムタイムをローカルファイルタイムに変換
    RtnCd = SystemTimeToFileTime(lpSystemTime, lpLocalFileTime)
    
    'ローカルファイルタイムをファイルタイムに変換
    RtnCd = LocalFileTimeToFileTime(lpLocalFileTime, lpLastWriteTime)
    
    'ファイルを開いてそのハンドルを得る
    hFile = CreateFileLong(TempFile, GENERIC_WRITE, 0, 0, OPEN_EXISTING, FILE_ATTRIBUTE_ARCHIVE, 0)
    
    '最終更新日を設定
    RtnCd = SetFileTimeLong(hFile, 0, 0, lpLastWriteTime)
    
    'ファイルハンドルを開放
    RtnCd = CloseHandle(hFile)
End Sub

'WindowsTempPathを取得
Function LsGetTempPath() As String
    Dim Gwdvar As String, Gwdvar_Length As Long
    Gwdvar = Space(255)
    Gwdvar_Length = GetTempPath(nSize:=255, lpBuffer:=Gwdvar)
    '2002/10/09 Bug Fix
    'LsGetTempPath = Trim$(Left$(Gwdvar, Gwdvar_Length))
    LsGetTempPath = LsNullTrim(Gwdvar)
End Function

'Null文字以降を削除
Function LsNullTrim(strExp As String) As String
    Dim i As Integer
    i = InStr(strExp, vbNullChar)
    If i > 1 Then
        LsNullTrim = Left$(strExp, i - 1)
    Else
        LsNullTrim = strExp
    End If
End Function