Класс для асинхронного ожидания объектов ядра

' Класс clsTrickWait - класс для асинхронного ожидания объектов ядра
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Option Explicit
 
Private Type WNDCLASSEX
    cbSize          As Long
    style           As Long
    lpfnwndproc     As Long
    cbClsextra      As Long
    cbWndExtra2     As Long
    hInstance       As Long
    hIcon           As Long
    hCursor         As Long
    hbrBackground   As Long
    lpszMenuName    As Long
    lpszClassName   As Long
    hIconSm         As Long
End Type
 
Private Type SThreadArg
    hHandle         As Long
    dwTime          As Long
    hwnd            As Long
    pObj            As Long
    idEvent         As Long
    numOfParams     As Long
    pResult         As Variant
    pHandle         As Variant
End Type
Private Type MThreadArg
    hHandle         As Long
    dwTime          As Long
    WaitAll         As Long
    nCount          As Long
    hwnd            As Long
    pObj            As Long
    idEvent         As Long
    numOfParams     As Long
    pHandle         As Variant
    pResult         As Variant
End Type
 
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetClassInfoEx Lib "user32" Alias "GetClassInfoExW" (ByVal hInstance As Long, ByVal lpClassName As Long, lpWndClassEx As WNDCLASSEX) As Long
Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassW" (ByVal lpClassName As Long, ByVal hInstance As Long) As Long
Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExW" (pcWndClassEx As WNDCLASSEX) As Integer
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
Private Declare 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 Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) 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
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function GetMem2 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (pArr() As Any) As Long
Private Declare Function SafeArrayAllocDescriptor Lib "oleaut32.dll" (ByVal cDims As Long, ppsaOut() As Any) As Long
Private Declare Function SafeArrayDestroyDescriptor Lib "oleaut32.dll" (psa() As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
 
Private Const STILL_ACTIVE              As Long = &H103&
Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&
Private Const MEM_COMMIT                As Long = &H1000&
Private Const MEM_RESERVE               As Long = &H2000&
Private Const MEM_RELEASE               As Long = &H8000&
Private Const HWND_MESSAGE              As Long = -3
Private Const WM_USER                   As Long = &H400
Private Const WM_ONWAIT                 As Long = WM_USER
Private Const HEAP_NO_SERIALIZE         As Long = &H1
 
Private Const MsgClass                  As String = "TrickWaitClass"
Private Const ErrInit                   As String = "Object not Initialized"
Private Const ErrAlloc                  As String = "Error allocating data"
Private Const ErrThrd                   As String = "Error creating thread"
 
Public Event OnWait(ByVal Handle As Long, ByVal Result As Long)
 
Dim hThread     As Long
Dim lpSThrd     As Long
Dim lpMThrd     As Long
Dim lpWndProc   As Long
Dim lpParam     As Long
Dim hwnd        As Long
Dim isInit      As Boolean
 
' // Запустить ожидание
Public Function vbWaitForSingleObject(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Boolean
 
    Dim param   As SThreadArg
    
    If Not isInit Then Err.Raise vbObjectError   513, , ErrInit: Exit Function
    If IsActive Then Exit Function
 
    param.hHandle = hHandle
    param.dwTime = dwMilliseconds
    param.hwnd = hwnd
    param.pObj = ObjPtr(Me)
    param.numOfParams = 2
    param.idEvent = 1
    param.pHandle = CVar(hHandle)
    param.pResult = CVar(0&)
    
    If lpParam = 0 Then
        lpParam = HeapAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE, Len(param)   8)
        If lpParam = 0 Then Err.Raise vbObjectError   514, , ErrAlloc: Exit Function
    End If
    
    memcpy ByVal lpParam, param, Len(param)
    
    hThread = CreateThread(ByVal 0&, 0, lpSThrd, ByVal lpParam, 0, 0)
    If hThread = 0 Then Err.Raise vbObjectError   515, , ErrThrd: Exit Function
    
    vbWaitForSingleObject = True
    
End Function
 
' // Запустить ожидание
Public Function vbWaitForMultipleObjects(ByVal nCount As Long, ByVal lpHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long) As Boolean
 
    Dim param   As MThreadArg
    
    If Not isInit Then Err.Raise vbObjectError   513, , ErrInit: Exit Function
    If IsActive Then Exit Function
 
    param.hHandle = lpHandles
    param.dwTime = dwMilliseconds
    param.nCount = nCount
    param.WaitAll = bWaitAll
    param.hwnd = hwnd
    param.pObj = ObjPtr(Me)
    param.numOfParams = 2
    param.idEvent = 1
    param.pHandle = CVar(lpHandles)
    param.pResult = CVar(0&)
    
    If lpParam = 0 Then
        lpParam = HeapAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE, Len(param))
        If lpParam = 0 Then Err.Raise vbObjectError   514, , ErrAlloc: Exit Function
    End If
    
    memcpy ByVal lpParam, param, Len(param)
    
    hThread = CreateThread(ByVal 0&, 0, lpMThrd, ByVal lpParam, 0, 0)
    If hThread = 0 Then Err.Raise vbObjectError   515, , ErrThrd: Exit Function
    
    vbWaitForMultipleObjects = True
    
End Function
 
' // Активно ли ожидание
Public Function IsActive() As Boolean
    
    If Not isInit Then Err.Raise vbObjectError   513, , ErrInit: Exit Function
    
    If hThread Then
        Dim code    As Long
        
        If GetExitCodeThread(hThread, code) Then
            If code = STILL_ACTIVE Then IsActive = True: Exit Function
        End If
        
        hThread = 0
    End If
End Function
 
' // Завершить ожидание
Public Function Abort() As Boolean
 
    If Not isInit Then Err.Raise vbObjectError   513, , ErrInit: Exit Function
 
    If IsActive Then
        Abort = TerminateThread(hThread, 0)
        If Abort Then WaitForSingleObject hThread, -1
    End If
End Function
 
Private Sub Class_Initialize()
 
    Dim cls     As WNDCLASSEX
    Dim isFirst As Boolean
    Dim count   As Long
    
    cls.cbSize = Len(cls)
    
    If GetClassInfoEx(App.hInstance, StrPtr(MsgClass), cls) = 0 Then
        
        If Not CreateAsm Then Exit Sub
        
        cls.hInstance = App.hInstance
        cls.lpfnwndproc = lpWndProc
        cls.lpszClassName = StrPtr(MsgClass)
        cls.cbClsextra = 8
        
        If RegisterClassEx(cls) = 0 Then Exit Sub
        
        isFirst = True
 
    End If
    
    hwnd = CreateWindowEx(0, StrPtr(MsgClass), 0, 0, 0, 0, 0, 0, HWND_MESSAGE, 0, App.hInstance, ByVal 0&)
    If hwnd = 0 Then Exit Sub
    
    If isFirst Then
        
        SetClassLong hwnd, 0, lpSThrd: count = 1
    Else
        
        lpSThrd = GetClassLong(hwnd, 0):    lpMThrd = lpSThrd   &H28:   lpWndProc = lpSThrd   &H56
        count = GetClassLong(hwnd, 4)   1
        
    End If
    
    SetClassLong hwnd, 4, count
    
    isInit = True
    
End Sub
 
Private Sub Class_Terminate()
    
    Dim count   As Long
    
    If Not isInit Then Exit Sub
        
    Abort
    If lpParam Then HeapFree GetProcessHeap(), HEAP_NO_SERIALIZE, lpParam
    
    count = GetClassLong(hwnd, 4) - 1
    
    DestroyWindow hwnd
    
    If count = 0 Then
        
        VirtualFree lpSThrd, 100, MEM_RELEASE
        UnregisterClass StrPtr(MsgClass), App.hInstance
        
    End If
    
End Sub
 
Private Function CreateAsm() As Boolean
    Dim lpWFSO  As Long
    Dim lpWFMO  As Long
    Dim lpSend  As Long
    Dim lpDef   As Long
    Dim lpEbMod As Long
    Dim lpDestr As Long
    Dim lpRaise As Long
    Dim hLib    As Long
    Dim isIDE   As Boolean
    Dim ptr     As Long
    
    Debug.Assert InIDE(isIDE)
 
    hLib = GetModuleHandle(StrPtr("kernel32")):                 If hLib = 0 Then Exit Function
    lpWFSO = GetProcAddress(hLib, "WaitForSingleObject"):       If lpWFSO = 0 Then Exit Function
    lpWFMO = GetProcAddress(hLib, "WaitForMultipleObjects"):    If lpWFMO = 0 Then Exit Function
    hLib = GetModuleHandle(StrPtr("user32")):                   If hLib = 0 Then Exit Function
    lpSend = GetProcAddress(hLib, "SendMessageW"):              If lpSend = 0 Then Exit Function
    lpDef = GetProcAddress(hLib, "DefWindowProcW"):             If lpDef = 0 Then Exit Function
    
    If isIDE Then
    
        lpDestr = GetProcAddress(hLib, "DestroyWindow"):        If lpDestr = 0 Then Exit Function
        hLib = GetModuleHandle(StrPtr("vba6")):                 If hLib = 0 Then Exit Function
        lpEbMod = GetProcAddress(hLib, "EbMode"):               If lpEbMod = 0 Then Exit Function
        
    End If
    
    hLib = GetModuleHandle(StrPtr("msvbvm60")):                 If hLib = 0 Then Exit Function
    lpRaise = GetProcAddress(hLib, "__vbaRaiseEvent"):          If lpRaise = 0 Then Exit Function
    
    ptr = VirtualAlloc(0, 100, MEM_RESERVE Or MEM_COMMIT, PAGE_EXECUTE_READWRITE)
    If ptr = 0 Then Exit Function
    
    Dim Dat()   As Long
    Dim i       As Long
    Dim lpArr   As Long
        
    SafeArrayAllocDescriptor 1, Dat
    lpArr = Not Not Dat
 
    GetMem4 ptr, ByVal lpArr   &HC: GetMem4 100&, ByVal lpArr   &H10
    
    Dat(0) = &H4244C8B:     Dat(1) = &H471FF51:     Dat(2) = &H69E831FF:    Dat(3) = &H59123456:    Dat(4) = &H8D204189:
    Dat(5) = &H50500C41:    Dat(6) = &H40068:       Dat(7) = &H871FF00:     Dat(8) = &H345653E8:    Dat(9) = &H4C212:
    Dat(10) = &H4244C8B:    Dat(11) = &H471FF51:    Dat(12) = &HFF0871FF:   Dat(13) = &HC71FF31:    Dat(14) = &H34563BE8:
    Dat(15) = &H41895912:   Dat(16) = &H14418D28:   Dat(17) = &H685050:     Dat(18) = &HFF000004:   Dat(19) = &H25E81071:
    Dat(20) = &HC2123456:   Dat(21) = &H81660004:   Dat(22) = &H8247C:      Dat(23) = &HE9057404:   Dat(24) = &H12345614
    
    GetMem4 lpWFSO - ptr - &HF, ByVal ptr   &HB     ' call WaitForSingleObject
    GetMem4 lpSend - ptr - &H25, ByVal ptr   &H21   ' call PostMessageW
    GetMem4 lpWFMO - ptr - &H3D, ByVal ptr   &H39   ' call WaitForMultipleObjects
    GetMem4 lpSend - ptr - &H53, ByVal ptr   &H4F   ' call PostMessageW
    GetMem4 lpDef - ptr - &H64, ByVal ptr   &H60    ' jmp  DefWindowProcW
    
    lpSThrd = ptr:          lpMThrd = ptr   &H28:   lpWndProc = ptr   &H56
    
    i = 25
    
    If isIDE Then
 
        Dat(i) = &H34560BE8:        Dat(i   1) = &H74C08412: Dat(i   2) = &H74013C09: Dat(i   3) = &H55FEE913
        Dat(i   4) = &H74FF1234:    Dat(i   5) = &HF5E80424: Dat(i   6) = &HE9123455: Dat(i   7) = &H123455F0
    
        GetMem4 lpEbMod - ptr - &H69, ByVal ptr   &H65       ' call EbMode
        GetMem4 lpDestr - ptr - &H7F, ByVal ptr   &H7B       ' call DestroyWindow
        GetMem4 lpDef - ptr - &H76, ByVal ptr   &H72         ' jmp  DefWindowProcW
        GetMem4 lpDef - ptr - &H84, ByVal ptr   &H80         ' jmp  DefWindowProcW
        
        i = i   8
        
    End If
    
    Dat(i) = &HC24748B:         Dat(i   1) = &H892CEC83:    Dat(i   2) = &HC931FCE7:    Dat(i   3) = &HA5F30BB1
    Dat(i   4) = &H3455DFE8:    Dat(i   5) = &H2CC48312:    Dat(i   6) = &H10C2
 
    GetMem4 lpRaise - ptr - (i * 4   &H15), ByVal ptr   (i * 4   &H11)   ' call __vbaRaiseEvent
    
    SafeArrayDestroyDescriptor Dat
    GetMem4 0&, ByVal ArrPtr(Dat)
    
    CreateAsm = True
    
End Function
 
Private Function InIDE(Value As Boolean) As Boolean: Value = True: InIDE = True: End Function

' Класс frmTrickWaitTest - примеры использование класса clsTrickWait
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Option Explicit
 
Private Const MAX_PATH = 260
 
Private Type OVERLAPPED
    Internal        As Long
    InternalHigh    As Long
    offset          As Long
    OffsetHigh      As Long
    hEvent          As Long
End Type
 
Private Type FILE_NOTIFY_INFORMATION
    dwNextEntryOffset           As Long
    dwAction                    As Long
    dwFileNameLength            As Long
    wcFileName(MAX_PATH * 2)    As Byte
End Type
 
Private Declare Function ReadDirectoryChanges Lib "kernel32.dll" Alias "ReadDirectoryChangesW" (ByVal hDirectory As Long, lpBuffer As Any, ByVal nBufferLength As Long, ByVal bWatchSubTree As Long, ByVal dwNotifyFilter As Long, ByVal lpBytesReturned As Long, lpOverlapped As Any, ByVal lpCompletionRoutine As Long) As Long
Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileW" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByRef lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CancelIo Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function CreateEvent Lib "kernel32" Alias "CreateEventW" (ByVal lpEventAttributes As Long, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As Long) As Long
Private Declare Function ResetEvent Lib "kernel32" (ByVal hEvent As Long) As Long
Private Declare Function memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) As Long
 
Private Declare Function CreateWaitableTimer Lib "kernel32" Alias "CreateWaitableTimerW" (lpTimerAttributes As Any, ByVal bManualReset As Long, ByVal lpName As Long) As Long
Private Declare Function SetWaitableTimer Lib "kernel32" (ByVal hTimer As Long, ByVal lpDueTime As Long, ByVal lPeriod As Long, ByVal pfnCompletionRoutine As Long, ByVal lpArgToCompletionRoutine As Long, ByVal fResume As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Declare Function VariantTimeToSystemTime Lib "oleaut32" (ByVal vTime As Date, lpSystemTime As Any) As Long
Private Declare Function SystemTimeToFileTime Lib "kernel32" (st As Any, ft As Currency) As Long
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As Currency, lpFileTime As Currency) As Long
 
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
 
Private Const SYNCHRONIZE                   As Long = &H100000
Private Const INFINITE                      As Long = -1
Private Const WAIT_OBJECT_0                 As Long = 0
Private Const FILE_LIST_DIRECTORY           As Long = &H1
Private Const FILE_SHARE_DELETE             As Long = &H4
Private Const FILE_SHARE_READ               As Long = &H1
Private Const FILE_SHARE_WRITE              As Long = &H2
Private Const FILE_FLAG_BACKUP_SEMANTICS    As Long = &H2000000
Private Const FILE_FLAG_OVERLAPPED          As Long = &H40000000
Private Const OPEN_EXISTING                 As Long = &H3
Private Const INVALID_HANDLE_VALUE          As Long = -1
Private Const FILE_NOTIFY_CHANGE_FILE_NAME  As Long = 1
Private Const FILE_ACTION_ADDED             As Long = &H1
Private Const FILE_ACTION_REMOVED           As Long = &H2
Private Const FILE_ACTION_RENAMED_OLD_NAME  As Long = &H4
Private Const FILE_ACTION_RENAMED_NEW_NAME  As Long = &H5
 
Dim WithEvents tmr  As clsTrickWait ' Объект событий ожидающего таймера
Dim WithEvents proc As clsTrickWait ' Объект событий процесса
Dim WithEvents mon  As clsTrickWait ' Объект событий мониторинга файлов
 
Dim hTimer      As Long     ' Описатель ожидающего таймера
Dim hProcess    As Long     ' Описатель ожидаемого процесса
Dim hDirectory  As Long     ' Описатель мониторящейся директории
Dim hEvent      As Long     ' Описатель события для мониторящейся директории
Dim bufEvent()  As Byte     ' Буфер уведомлений для мониторинга файлов
Dim ovr         As OVERLAPPED
 
'  ----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----= 
' |                                                                                                                             |
' |         Пример использования класса clsTrickWait для отслеживания изменений в директории используя объект-событие           |
' |                                                                                                                             |
'  ----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----= 
 
Private Sub cmdMonitor_Click()
    
    ' Проверяем если директория открыта, то значит останавливаем
    If hDirectory Then
        ' Завершаем ожидание
        mon.Abort
        ' Закрываем описатели события и директории
        CloseHandle hEvent:     hEvent = 0
        CloseHandle hDirectory: hDirectory = 0
        ' Меняем надпись
        cmdMonitor.Caption = "Start"
        Exit Sub
    End If
    ' Открываем директорию для мониторинга
    hDirectory = CreateFile(StrPtr(txtMonitor), FILE_LIST_DIRECTORY, FILE_SHARE_READ Or FILE_SHARE_WRITE Or FILE_SHARE_DELETE, _
                        ByVal 0&, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS Or FILE_FLAG_OVERLAPPED, 0)
    ' При ошибке уведомляем и выходим
    If hDirectory = INVALID_HANDLE_VALUE Then MsgBox "Error open directory", vbExclamation: Exit Sub
    ' Создаем событие для уведомления
    hEvent = CreateEvent(0, True, True, 0)
    ' При ошибке  уведомляем и выходим
    If hEvent = 0 Then
    
        CloseHandle hDirectory: hDirectory = 0
        MsgBox "Error create notify event", vbExclamation
        Exit Sub
        
    End If
    ' Заполняем структуру OVERLAPPED для асинхронного вызова
    ovr.hEvent = hEvent
    ' Выделяем буфер для уведомлений
    ReDim bufEvent(16383)
    ' начинаем мониторить в асинхронном режиме
    If ReadDirectoryChanges(hDirectory, bufEvent(0), UBound(bufEvent)   1, False, FILE_NOTIFY_CHANGE_FILE_NAME, 0, ovr, 0) = 0 Then
        ' При ошибке  уведомляем и выходим
        MsgBox "Error start monitor", vbExclamation
        CloseHandle hEvent:     hEvent = 0
        CloseHandle hDirectory: hDirectory = 0
        Exit Sub
        
    End If
    ' Запускаем асинхронное уведомление
    mon.vbWaitForSingleObject hEvent, INFINITE
    ' Установка интерфейса
    cmdMonitor.Caption = "Stop"
    lstMonitor.Clear
    
End Sub
 
' // Событие возникает при изменениях в директории на которые мы подписаны
Private Sub mon_OnWait(ByVal Handle As Long, ByVal Result As Long)
    Dim notify  As FILE_NOTIFY_INFORMATION
    Dim idx     As Long
    Dim name    As String
    ' Проход по буферу уведомлений
    Do
        ' Копируем во временную структуру уведомление
        ' Здесь правильнее сделать через указатели, но для примера я оставил так (более понятно)
        memcpy notify, bufEvent(idx), Len(notify)
        ' Узнаем имя файла
        name = Chr$(34) & Left$(notify.wcFileName, notify.dwFileNameLength \ 2) & Chr$(34)
        ' Проверяем тип уведомления
        Select Case notify.dwAction
        Case FILE_ACTION_ADDED:             name = "ADDED: " & name                 ' Файл добавлен
        Case FILE_ACTION_REMOVED:           name = "REMOVED: " & name               ' Файл удален
        Case FILE_ACTION_RENAMED_OLD_NAME:  name = "RENAMED (old name): " & name    ' Файл переименован - это старое имя
        Case FILE_ACTION_RENAMED_NEW_NAME:  name = "RENAMED (new name): " & name    ' Файл переименован - это новое имя
        End Select
        ' Добавить в список
        lstMonitor.AddItem name
        ' Переход к следующему уведомлению
        idx = idx   notify.dwNextEntryOffset
        ' Пока есть уведомления в буфере повторяем
    Loop While notify.dwNextEntryOffset
    ' Сбрасываем событие
    ResetEvent Handle
    ' Заполняем структуру OVERLAPPED
    ovr.hEvent = Handle
    ' Запускаем мониторинг
    Call ReadDirectoryChanges(hDirectory, bufEvent(0), UBound(bufEvent)   1, False, FILE_NOTIFY_CHANGE_FILE_NAME, 0, ovr, 0)
    ' Снимаем старое уведомление
    mon.Abort
    ' Запускаем новое
    mon.vbWaitForSingleObject Handle, INFINITE
 
End Sub
 
'  ----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----= 
' |                                                                                                                             |
' |                     Пример использования класса clsTrickWait для отслеживания завершения приложения                         |
' |                                                                                                                             |
'  ----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----= 
 
Private Sub cmdRun_Click()
    Dim pid         As Long
    Dim hProcess    As Long
    ' Запускаем процесс
    pid = Shell(txtProcess)
    ' Открываем его, для синхронизации
    hProcess = OpenProcess(SYNCHRONIZE, False, pid)
    ' Если активно асинхронное уведомление, то спрашиваем об окончании отслеживания
    If proc.IsActive Then
        Select Case MsgBox("Process enabled. Abort?", vbYesNo Or vbQuestion)
        Case vbYes: proc.Abort  ' Прекращаем отслеживать
        Case Else: Exit Sub
        End Select
    End If
    ' Начинаем отслеживать окончание процесса
    proc.vbWaitForSingleObject hProcess, INFINITE
    
End Sub
 
' // Событие вызывается после завершения приложения
Private Sub proc_OnWait(ByVal Handle As Long, ByVal Result As Long)
    MsgBox "Process event." & vbNewLine & "Handle = " & Handle & vbNewLine & "Result = " & Result
    ' Закрываем описатель объекта процесса
    CloseHandle Handle
End Sub
'  ----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----= 
' |                                                                                                                             |
' |                   Пример использования класса clsTrickWait для отслеживания тика ожидающего таймера                         |
' |                                                                                                                             |
'  ----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----= 
 
Private Sub cmdSetTimer_Click()
    On Error GoTo Cancel
    
    Dim Dat     As Date
    Dim st(8)   As Integer
    Dim ft      As Currency
    Dim lt      As Currency
    
    ' Преобразуем к системному времени
    Dat = CDate(txtDueTime)
    VariantTimeToSystemTime Dat, st(0)
    SystemTimeToFileTime st(0), lt
    LocalFileTimeToFileTime lt, ft
    ' Устанавливаем таймер
    SetWaitableTimer hTimer, VarPtr(ft), 0, 0, 0, 0
    ' Если активно асинхронное уведомление, то спрашиваем об окончании отслеживания
    If tmr.IsActive Then
        Select Case MsgBox("Timer enabled. Abort?", vbYesNo Or vbQuestion)
        Case vbYes: tmr.Abort  ' Прекращаем отслеживать
        Case Else: Exit Sub
        End Select
    End If
    ' Начинаем отслеживать "тик"
    tmr.vbWaitForSingleObject hTimer, INFINITE
    Exit Sub
    
Cancel:
    
    MsgBox "Error", vbExclamation
    
End Sub
 
' // Событие вызывается после тика таймера
Private Sub tmr_OnWait(ByVal Handle As Long, ByVal Result As Long)
    MsgBox "Timer event." & vbNewLine & "Handle = " & Handle & vbNewLine & "Result = " & Result
End Sub
 
'  ----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----= 
' |                                                                                                                             |
' |                                              Процедуры инициализации                                                        |
' |                                                                                                                             |
'  ----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----=----= 
 
Private Sub Form_Load()
    ' Создаем объекты для уведомлений
    Set tmr = New clsTrickWait
    Set mon = New clsTrickWait
    Set proc = New clsTrickWait
    ' Создаем ожидающий таймер
    hTimer = CreateWaitableTimer(ByVal 0&, False, 0)
    ' Создаем значения по умолчанию для пользовательских элементов
    txtDueTime = Now
    txtMonitor = Environ("WINDIR")
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    ' Прервывание ожиданий
    mon.Abort
    tmr.Abort
    proc.Abort
    ' Если мониторинг
    If hDirectory Then
        ' Остановка ожидания мониторинга
        CancelIo hDirectory
    End If
    ' Закрываем описатели
    CloseHandle hDirectory
    CloseHandle hEvent
    CloseHandle hTimer
    CloseHandle hProcess
End Sub