Option Explicit
Private Type FILE_NOTIFY_INFORMATION
NextEntryOffset As Long
Action As Long
FileNameLength As Long
FileName As String
End Type
Private Const FILE_FLAG_OVERLAPPED = &H40000000
Private Const FILE_LIST_DIRECTORY = &H1
Private Const FILE_SHARE_READ = &H1&
Private Const FILE_SHARE_DELETE = &H4&
Private Const OPEN_EXISTING = 3
Private Const CREATE_NEW = 1
Private Const FILE_FLAG_BACKUP_SEMANTICS = &H2000000
Private Const FILE_NOTIFY_CHANGE_FILE_NAME = &H1&
Private Const FILE_NOTIFY_CHANGE_LAST_WRITE = &H10&
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const FILE_NOTIFY_CHANGE_ATTRIBUTES As Long = &H4
Private Const FILE_NOTIFY_CHANGE_DIR_NAME As Long = &H2
Private Const FILE_ACTION_ADDED = &H1&
Private Const FILE_ACTION_REMOVED = &H2&
Private Const FILE_ACTION_MODIFIED = &H3&
Private Const FILE_ACTION_RENAMED_OLD_NAME = &H4&
Private Const FILE_ACTION_RENAMED_NEW_NAME = &H5&
Private Declare PtrSafe Sub MoveMemory Lib _
"kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpcSource As Any, ByVal dwLength As Long)
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare PtrSafe Function ReadDirectoryChangesW Lib "kernel32" _
(ByVal hDirectory As Long, lpBuffer As Any, ByVal nBufferLength As Long, _
ByVal bWatchSubtree As Long, ByVal dwNotifyFilter As Long, _
lpBytesReturned As Long, ByVal PassZero As Long, ByVal PassZero As Long) As Long
Private Declare PtrSafe Function CreateFile Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
ByVal PassZero As Long, ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, ByVal PassZero As Long) As Long
Private Declare PtrSafe Function CreateThread Lib "kernel32" _
(lpThreadAttributes As Any, ByVal dwStackSize As Long, _
ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, _
lpThreadID As Long) As Long
Private Declare PtrSafe Function TerminateThread Lib "kernel32" _
(ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
'Get the directory chages using ReadDirectoryChangesW
Private Const FILE_NOTIF_GLOB = FILE_NOTIFY_CHANGE_ATTRIBUTES Or _
FILE_NOTIFY_CHANGE_FILE_NAME Or _
FILE_NOTIFY_CHANGE_DIR_NAME Or _
FILE_NOTIFY_CHANGE_ATTRIBUTES Or _
FILE_NOTIFY_CHANGE_LAST_WRITE
Private WSubFolder As Boolean
Private nBufLen As Long
Private nReadLen As Long
Private sAction As String
Private fiBuffer As FILE_NOTIFY_INFORMATION
Private cBuffer() As Byte
Private cBuff2() As Byte
Private lpBuf As Long
Private WatchStart As Boolean
Private DirHndl As Long
Private FolderPath As String
Private ThreadHandle As Long
Private Function GetDirHndl(ByVal PathDir As String) As Long
On Error Resume Next
Dim hDir As Long
If Right(PathDir, 1) <> "\" Then PathDir = PathDir + "\"
hDir = CreateFile(PathDir, FILE_LIST_DIRECTORY, _
FILE_SHARE_READ + FILE_SHARE_WRITE + FILE_SHARE_DELETE, _
ByVal 0&, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS Or FILE_FLAG_OVERLAPPED, ByVal 0&)
GetDirHndl = hDir
End Function
Private Sub StartWatch_CallBack()
If (DirHndl = 0) Or (DirHndl = -1) Then Exit Sub
nBufLen = 1024
ReDim cBuffer(0 To nBufLen)
Call ReadDirectoryChangesW(DirHndl, cBuffer(0), nBufLen, WSubFolder, _
FILE_NOTIF_GLOB, nReadLen, 0, 0)
End Sub
Private Function GetChanges() As String
On Error Resume Next
Dim fName As String
MoveMemory fiBuffer.NextEntryOffset, cBuffer(0), 4
MoveMemory fiBuffer.Action, cBuffer(4), 4
MoveMemory fiBuffer.FileNameLength, cBuffer(8), 4
ReDim cBuff2(0 To fiBuffer.FileNameLength)
MoveMemory cBuff2(0), cBuffer(12), fiBuffer.FileNameLength
fiBuffer.FileName = cBuff2
Select Case fiBuffer.Action
Case FILE_ACTION_ADDED
sAction = "Added file"
Case FILE_ACTION_REMOVED
sAction = "Removed file"
Case FILE_ACTION_MODIFIED
sAction = "Modified file"
Case FILE_ACTION_RENAMED_OLD_NAME
sAction = "Renamed from"
Case FILE_ACTION_RENAMED_NEW_NAME
sAction = "Renamed to"
Case Else
sAction = "Unknown"
End Select
fName = sAction + "-" + FolderPath + fiBuffer.FileName
If sAction <> "Unknown" Then GetChanges = fName
End Function
Private Sub ClearHndl(Handle As Long)
CloseHandle Handle
Handle = 0
End Sub
'______________________________________________________________________________________
Private Sub DisplayInfoOnSheet(i As Long, changes As String)
With ThisWorkbook.Sheets(1)
.Cells(i, 1) = changes
.Columns("A:A").EntireColumn.AutoFit
End With
End Sub
Sub StartWatch()
Dim changes As String
Dim WaitNum As Long
Dim i As Long
WSubFolder = True
If Not WatchStart Then
WatchStart = True
Else
MsgBox " The Directory Watcher is already enabled", vbInformation
Exit Sub
End If
'Get Folder Handle
FolderPath = "C:\test\" 'change this path as required
If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath + "\"
DirHndl = GetDirHndl(FolderPath)
If (DirHndl = 0) Or (DirHndl = -1) Then MsgBox "Cannot create handle": Exit Sub
i = 1
Do
'Create thread to Watch changes
ThreadHandle = CreateThread(ByVal 0&, ByVal 0&, AddressOf StartWatch_CallBack, 0, 0, 0)
Do
WaitNum = WaitForSingleObject(ThreadHandle, 50)
DoEvents
Loop Until (WaitNum = 0) Or (WatchStart = False)
changes = ""
If WaitNum = 0 Then changes = GetChanges
If changes <> "" Then Call DisplayInfoOnSheet(i, changes): i = i + 1
Loop Until Not WatchStart
'Terminate the Thread & Clear Handle
If DirHndl <> 0 Then ClearHndl DirHndl
If ThreadHandle <> 0 Then Call TerminateThread(ThreadHandle, ByVal 0&): ThreadHandle = 0
End Sub
Sub StopWatch()
WatchStart = False
With ThisWorkbook.Sheets(1)
.Columns("A:A").ClearContents
.Columns("A:A").ColumnWidth = Columns("B:B").ColumnWidth
End With
End Sub
|
