Hello everyone! Developed a class for asynchronous standby kernel objects. The class generates an event when setting the object to the signaled state or timeout. Works with any objects.* The class has 3 methods: vbWaitForSingleObject, vbWaitForMultipleObjects, IsActive, Abort. The first two are similar to call API functions of the same name without the prefix "vb" and start waiting for the object in the new thread. Methods terminated immediately. Upon completion of the functions in the new thread is generated event OnWait, the parameters of which contains a handle of the object and the returned value. If successful, the method returns True, otherwise False, and throws an exception. IsActive - returns True, if there is the expectation, otherwise False. Abort - aborts expectation on success returns True.* The instance can handle only one call at a time.* In the example I have prepared 3 cases of the use of this class: tracking teak waiting timer, tracking the completion of the application, tracking file operations in a folder.
Module clsTrickWait.cls:
Module clsTrickWait.cls:
Code:
' Класс 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