На момент создания этого класса я не знал о Waiter'е GSerg'а. Решил выложить свой класс для тех же целей. Разработал класс для асинхронного ожидания объектов ядра. Класс генерирует событие при установке объекта в сигнальное состояние или при таймауте. Работает с любыми объектами.
Класс имеет 3 метода vbWaitForSingleObject, vbWaitForMultipleObjects, IsActive, Abort. Первые два аналогичны вызову одноименных API функций без префикса "vb" и запускают ожидание объекта в новом потоке. Методы завершаются немедленно. При завершении функций в новом потоке генерируется событие OnWait, в параметрах которого содержится описатель объекта и возвращенное значение. При удачном завершении методы возвращают True, иначе False, также генерируются исключения.
IsActive - возвращает True, если идет ожидание, иначе False.
Abort - прерывает ожидание, при удачном выполнении возвращает True.
Экземпляр класса может обрабатывать только один вызов за раз.
В примере я подготовил 3 случая использования данного класса: отслеживание тика ожидающего таймера, отслеживание завершения приложения, отслеживание файловых операций в любой папке.
- Код: Выделить всё
' Класс 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.numOfParams = 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
Как это работает.
Создается окно для приема уведомлений в главном потоке. При вызове метода ожидания создается новый поток с одноименной API функцией. Когда функция отрабатывает (по сигнальному состоянию, таймауту или ошибке) она передает сообщение нашему окну, которое обрабатывая его генерирует событие для текущего экземпляра объекта. Все манипуляции сделаны на ассемблере, что позволило обойтись одним классом (без модулей), к тому же для всех экземпляров используется один код. Также сделал небольшие проверки в IDE (в скомпилированном виде они отсутствуют), поэтому можно останавливать кнопкой "в среде", жать паузы без последствий (события просто не будут вызваны). Единственный способ "вылета" может произойти если запустить ожидание, остановить его кнопкой стоп (не вызвать деструктор). Потом опять запустить среду - если в этот момент отработает событие из прошлого запуска - будет вылет, т.к. того объекта уже нет.
Код на ассемблере (NASM):
- Код: Выделить всё
[BITS 32]
WAITFORSINGLEOBJECT:
mov ecx, [esp+4]
push ecx
push dword [ecx+4] ; dwTime
push dword [ecx] ; hHandle
call 0x12345678 ; WaitForSingleObject
pop ecx
mov dword [ecx+32], eax ; Long -> Variant
lea eax, [ecx+12]
push eax ; Параметры в RAISE (lParam)
push eax ; --- (wParam)
push 0x400 ; WM_ONWAIT (uMsg)
push dword [ecx+8] ; hWnd
call 0x12345678 ; PostMessage
ret 0x4
WAITFORMULTIPLEOBJECTS:
mov ecx, [esp+4]
push ecx
push dword [ecx+4] ; dwTime
push dword [ecx+8] ; WaitAll
push dword [ecx] ; lpHandles
push dword [ecx+12] ; nCount
call 0x12345678 ; WaitForMultipleObjects
pop ecx
mov dword [ecx+40], eax ; Long -> Variant
lea eax, [ecx+20]
push eax ; Параметры в RAISE (lParam)
push eax ; --- (wParam)
push 0x400 ; WM_ONWAIT (uMsg)
push dword [ecx+16] ; hWnd
call 0x12345678 ; PostMessage
ret 0x4
WINDOWPROC:
cmp word [esp+8], 0x400 ; If Msg = WM_ONWAIT
jz WM_ONWAIT
jmp 0x12345678 ; DefWindowProc
WM_ONWAIT:
; Процедура для исключения падения в IDE
call 0x12345678 ; call EbMode
test al,al ; Если остановлен
jz CLEAR
cmp al,1 ; Если запущен
jz RAISE
jmp 0x12345678 ; DefWindowProc
CLEAR: ; Очистка
push dword [esp+4] ; hwnd
call 0x12345678 ; DestroyWindow
jmp 0x12345678 ; DefWindowProc
; Конец заглушки
RAISE: ; Возбуждение события
mov esi, dword [esp+0xc] ; Указатель на источник
sub esp, 44 ; 44 байт параметров
mov edi, esp ; Указатель на стек
cld ; df = 0 (увеличение счетчиков)
xor ecx,ecx
mov cl,11 ; 44 Байт (параметры _vbaRaiseEvent и аргументы
rep movsd
call 0x12345678 ; __vbaRaiseEvent
add esp, 44
ret 0x10
Последняя версия.
