VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "WatchFolder" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '************************************************************************************************* '* WatchFolder - Self-contained class for watching changes in folders & files '* -------------------------------------------------------------------------- '* By Vesa Piittinen aka Merri, http://vesa.piittinen.name/ '* '* LICENSE '* ------- '* http://creativecommons.org/licenses/by-sa/1.0/fi/deed.en '* '* Terms: 1) If you make your own version, share using this same license. '* 2) When used in a program, mention my name in the program's credits. '* 3) Free for commercial and non-commercial usage. '* 4) Use at your own risk. No support guaranteed. '* '* REQUIREMENTS '* ------------ '* Huh what? Just this one class module. No extra files required. '* '* HOW TO ADD TO YOUR PROGRAM '* -------------------------- '* 1) Copy WatchFolder.cls to your project folder. '* 2) In your project, add WatchFolder.cls '* '* VERSION HISTORY '* --------------- '* Version 1.0 (2008-10-03) '* - Initial release. '* '* CREDITS '* ------- '* Paul Caton and LaVolpe for their work on SelfSub, SelfHook and SelfCallback '************************************************************************************************* Option Explicit Public Event Change(ByVal Filename As String, ByVal Action As WatchFileAction) Public Event Completed() Public Event Error(ByVal ErrorCode As Long) Private Type FILE_NOTIFY_INFORMATION_HEADER NextEntryOffset As Long Action As WatchFileAction FilenameLength As Long End Type Private Type OVERLAPPED Internal As Long InternalHigh As Long Offset As Long OffsetHigh As Long hEvent As Long End Type Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As Long, 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 Private Declare Function GetLastError Lib "kernel32" () As Long Private Declare Sub PutMem4 Lib "msvbvm60" (Destination As Any, Value As Any) Private Declare 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 OverlappedHandle As Long, ByVal CallbackAddress As Long) As Long Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal OleStr As Long, ByVal bLen As Long) As Long Public Enum WatchFileAction [File Added] = &H1& [File Removed] = &H2& [File Modified] = &H3& [File Rename From] = &H4& [File Rename To] = &H5& End Enum Private Const ERROR_INVALID_FUNCTION = 1& Private Const ERROR_INVALID_PARAMETER = 7& Private Const ERROR_NOACCESS = 998& Private Const ERROR_NOTIFY_ENUM_DIR = 1022& Private Const FILE_FLAG_BACKUP_SEMANTICS = &H2000000 Private Const FILE_FLAG_OVERLAPPED = &H40000000 Private Const FILE_LIST_DIRECTORY = &H1 Private Const FILE_NOTIFY_CHANGE_ATTRIBUTES = &H4& Private Const FILE_NOTIFY_CHANGE_DIR_NAME = &H2& Private Const FILE_NOTIFY_CHANGE_FILE_NAME = &H1& Private Const FILE_NOTIFY_CHANGE_LAST_WRITE = &H10& 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 Const FILE_SHARE_DELETE = &H4& Private Const FILE_SHARE_READ = &H1& Private Const FILE_SHARE_WRITE = &H2& Private Const INVALID_HANDLE = -1& Private Const OPEN_EXISTING = &H3& Private m_Buffer As String Private m_Callback As Long Private m_Dir As String Private m_Directory As Long Private m_Overlapped As OVERLAPPED Private m_SubFolders As Long ' the following are the requirements for SelfCallback Private Declare Sub GetMem1 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Byte) Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Long) Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long Private Declare Sub PutMem2 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Integer) Private Declare Sub RtlMachineCodeCopy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Long, Source As MachineCode, ByVal Length As Long) Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long ' self-documentation: less comments and constants Private Type MachineCode ' 37 * 4 = 148 bytes ' thunk OwnerPtr As Long ' 0 CallbackAddress As Long ' 1 API_EbMode As Long ' 2 API_IsBadCodePtr As Long ' 3 API_KillTimer As Long ' 4 ' code MC1(5 To 5) As Long ' 5 AllocatedDataPtr As Long ' 6 MC2(7 To 17) As Long ' 7 - 17 ParamCount As Long ' 18 MC3(19 To 35) As Long ' 19 - 35 Ordinal As Long ' 36 End Type Public Function Continue() As Boolean Dim lngResult As Long, lngReturn As Long If m_Directory <> INVALID_HANDLE Then ' get the buffer lngResult = ReadDirectoryChangesW(m_Directory, ByVal StrPtr(m_Buffer), LenB(m_Buffer), CLng(m_SubFolders), FILE_NOTIF_GLOB, lngReturn, VarPtr(m_Overlapped), m_Callback) ' handle the return value Select Case lngResult Case 0 RaiseEvent Error(GetLastError) CloseHandle m_Directory m_Directory = INVALID_HANDLE Case ERROR_INVALID_FUNCTION, ERROR_INVALID_PARAMETER, ERROR_NOACCESS, ERROR_NOTIFY_ENUM_DIR RaiseEvent Error(lngResult) CloseHandle m_Directory m_Directory = INVALID_HANDLE Case Else Continue = True End Select End If End Function Public Function Directory() As String Directory = m_Dir End Function Public Function Watch(ByRef Directory As String, Optional ByVal SubFolders As Boolean = True) As Boolean Dim lngResult As Long, lngReturn As Long ' close existing directory handle If m_Directory <> INVALID_HANDLE Then CloseHandle m_Directory ' remember the directory name m_Dir = Directory m_SubFolders = SubFolders ' attempt to open a handle to directory m_Directory = CreateFileW(StrPtr(Directory), FILE_LIST_DIRECTORY, FILE_SHARE_READ Or FILE_SHARE_WRITE Or FILE_SHARE_DELETE, 0, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS Or FILE_FLAG_OVERLAPPED, 0) ' did we get it? If m_Directory <> INVALID_HANDLE Then Watch = Continue End If End Function Private Function Private_Start(Optional ByVal Ordinal As Long = 1, Optional ByVal ParamCount As Long = 4) As Long Dim bytValue As Byte, bytSignature As Byte, lngA As Long Dim lngAddress As Long, lngMethod As Long, lngObject As Long Dim lngCallback As Long, lngMCmem As Long, udtMC As MachineCode ' start only if enabled, interval is set and we have not done this already If m_Callback = 0 Then ' get object pointer lngObject = ObjPtr(Me) ' get VTable address GetMem4 lngObject, lngAddress ' Class method (see SelfSub code for non-Class values) lngAddress = lngAddress + &H1C& ' get method pointer GetMem4 lngAddress, lngMethod ' get method signature byte: &H33 = pseudo-code, &HE9 = native code GetMem1 lngMethod, bytSignature ' next VTable address lngAddress = lngAddress + 4& ' try a "reasonable" amount of VTable entries For lngA = 511 To 1 Step -1 ' get method pointer GetMem4 lngAddress, lngMethod ' see if we are out of VTable (I use "Then Else" because True conditions are faster) If IsBadCodePtr(lngMethod) = 0& Then Else Exit For ' get method signature byte GetMem1 lngMethod, bytValue ' if it is invalid we are out of VTable If bytValue = bytSignature Then Else Exit For ' try next one lngAddress = lngAddress + 4& Next lngA ' if lngA = 0 we looped through the entire loop; if that did not happen, we get the pointer If lngA Then GetMem4 lngAddress - (Ordinal * 4&), lngCallback ' verify we got the TimerProc callback address of ordinal 1 If lngCallback Then ' allocate executable memory lngMCmem = VirtualAlloc(0, LenB(udtMC), &H1000&, &H40&) 'Length, MEM_COMMIT, PAGE_RWX ' verify we got it If lngMCmem Then With udtMC ' thunk .OwnerPtr = lngObject .CallbackAddress = lngCallback If App.LogMode = 0 Then ' for IDE safety, store the EbMode function address in the thunk data .API_EbMode = GetProcAddress(GetModuleHandleA("vba6"), "EbMode") End If .API_IsBadCodePtr = GetProcAddress(GetModuleHandleA("kernel32"), "IsBadCodePtr") '.API_KillTimer = GetProcAddress(GetModuleHandleA("user32"), "KillTimer") ' actual machine code .MC1(5&) = &HBB60E089: .MC2(7&) = &H73FFC589 .MC2(8&) = &HC53FF04: .MC2(9&) = &H59E80A74 .MC2(10) = &HE9000000: .MC2(11) = &H30& .MC2(12) = &H87B81: .MC2(13) = &H75000000 .MC2(14) = &H9090902B: .MC2(15) = &H42DE889 .MC2(16) = &H50000000: .MC2(17) = &HB9909090 .MC3(19) = &H90900AE3: .MC3(20) = &H8D74FF .MC3(21) = &H9090FAE2: .MC3(22) = &H53FF33FF .MC3(23) = &H90909004: .MC3(24) = &H2BADC261 .MC3(25) = &H3D0853FF: .MC3(26) = &H1& .MC3(27) = &H23DCE74: .MC3(28) = &H74000000 .MC3(29) = &HAE807: .MC3(30) = &H90900000 .MC3(31) = &H4589C031: .MC3(32) = &H90DDEBFC .MC3(33) = &HFF0C75FF: .MC3(34) = &H53FF0475 .MC3(35) = &HC310& ' settings within the code .AllocatedDataPtr = lngMCmem .Ordinal = Ordinal .ParamCount = ParamCount PutMem2 VarPtr(.MC3(24)) + 2&, CInt(ParamCount * 4&) End With ' copy thunk code to executable memory RtlMachineCodeCopy ByVal lngMCmem, udtMC, LenB(udtMC) ' remember the procedure address (add thunk offset) Private_Start = lngMCmem + &H14& End If End If End If End Function Private Sub Private_Stop() ' only do this if we still have the procedure If m_Callback Then ' free the procedure callback VirtualFree m_Callback, 0&, &H8000& 'MEM_RELEASE ' reset procedure pointer to prevent this getting ran twice m_Callback = 0 End If End Sub Private Sub Class_Initialize() ' create an IDE safe callback address m_Callback = Private_Start(1, 3) ' invalidate handle m_Directory = INVALID_HANDLE ' allocate BSTR for data PutMem4 ByVal VarPtr(m_Buffer), ByVal SysAllocStringByteLen(0, 4096) End Sub Private Sub Class_Terminate() ' close existing directory handle If m_Directory <> INVALID_HANDLE Then CloseHandle m_Directory ' destroy callback Private_Stop End Sub ' must be the last procedure, ordinal #1! Private Function FileIOCompletionRoutine(ByVal ErrorCode As Long, ByVal NumberOfBytesTransfered As Long, ByRef Overlap As OVERLAPPED) As Long Dim lngPos As Long, udtFNIH As FILE_NOTIFY_INFORMATION_HEADER, lngDir As Long Debug.Print "FileIOCompletionRoutine" ' see what happened: error if got nothing If NumberOfBytesTransfered > 0 Then ' prevent invalid calls to Continue lngDir = m_Directory m_Directory = INVALID_HANDLE ' we raise events for each event Do ' copy from buffer to User Defined Type RtlMoveMemory udtFNIH, ByVal StrPtr(m_Buffer) + lngPos, Len(udtFNIH) ' raise the event: get the string and action RaiseEvent Change(MidB$(m_Buffer, lngPos + 13, udtFNIH.FilenameLength), udtFNIH.Action) ' jump to the next position lngPos = lngPos + 12 + udtFNIH.NextEntryOffset ' end when there is no next one Loop Until udtFNIH.NextEntryOffset = 0 ' make continue calls valid again m_Directory = lngDir ' done! RaiseEvent Completed Else ' error RaiseEvent Error(ErrorCode) End If End Function