Форум программистов, компьютерный форум, киберфорум
The trick
Войти
Регистрация
Восстановить пароль
Оценить эту запись

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

Запись от The trick размещена 07.09.2014 в 00:54
Обновил(-а) The trick 02.04.2015 в 21:11

Разработал класс для асинхронного ожидания объектов ядра. Класс генерирует событие при установке объекта в сигнальное состояние или при таймауте. Работает с любыми объектами.
Класс имеет 3 метода vbWaitForSingleObject, vbWaitForMultipleObjects, IsActive, Abort. Первые два аналогичны вызову одноименных API функций без префикса "vb" и запускают ожидание объекта в новом потоке. Методы завершаются немедленно. При завершении функций в новом потоке генерируется событие OnWait, в параметрах которого содержится описатель объекта и возвращенное значение. При удачном завершении методы возвращают True, иначе False, также генерируются исключения.
IsActive - возвращает True, если идет ожидание, иначе False.
Abort - прерывает ожидание, при удачном выполнении возвращает True.
Экземпляр класса может обрабатывать только один вызов за раз.
В примере я подготовил 3 случая использования данного класса: отслеживание тика ожидающего таймера, отслеживание завершения приложения, отслеживание файловых операций в папке.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
' Класс 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
Пример использования:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
' Класс 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
Как это работает.
Создается окно для приема уведомлений в главном потоке. При вызове метода ожидания создается новый поток с одноименной API функцией. Когда функция отрабатывает (по сигнальному состоянию, таймауту или ошибке) она передает сообщение нашему окну, которое обрабатывая его генерирует событие для текущего экземпляра объекта. Все манипуляции сделаны на ассемблере, что позволило обойтись одним классом (без модулей), к тому же для всех экземпляров используется один код. Также сделал небольшие проверки в IDE (в скомпилированном виде они отсутствуют), поэтому можно останавливать кнопкой "в среде", жать паузы без последствий (события просто не будут вызваны). Единственный способ "вылета" может произойти если запустить ожидание, остановить его кнопкой стоп (не вызвать деструктор). Потом опять запустить среду - если в этот момент отработает событие из прошлого запуска - будет вылет, т.к. того объекта уже нет.
Код на ассемблере (NASM):
Assembler
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
[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
Миниатюры
Нажмите на изображение для увеличения
Название: Безымянный.png
Просмотров: 429
Размер:	6.6 Кб
ID:	2696  
Вложения
Тип файла: rar TrickWait.rar (22.2 Кб, 237 просмотров)
Размещено в Без категории
Показов 8872 Комментарии 4
Всего комментариев 4
Комментарии
  1. Старый комментарий
    Аватар для Yury Komar
    тоесть с данным классом можно сделать свой пакетный установщик. который бы ожидал завершение установки одного софта и затем запускал другой? Неплохо, если так... Осталось научиться его применять )
    Thanks a lot! ))
    Запись от Yury Komar размещена 02.10.2014 в 16:32 Yury Komar вне форума
  2. Старый комментарий
    Цитата:
    Сообщение от Yury Komar Просмотреть комментарий
    тоесть с данным классом можно сделать свой пакетный установщик. который бы ожидал завершение установки одного софта и затем запускал другой? Неплохо, если так... Осталось научиться его применять )
    Thanks a lot! ))
    Да. Там же есть пример с ожиданием блокнота.
    Запись от The trick размещена 02.10.2014 в 16:36 The trick на форуме
  3. Старый комментарий
    Аватар для Dragokas
    Есть вопрос по vbWaitForMultipleObjects.
    Можешь, пожалуйста, посмотреть эту тему?
    Запись от Dragokas размещена 09.12.2014 в 00:05 Dragokas вне форума
  4. Старый комментарий
    Цитата:
    Сообщение от Dragokas Просмотреть комментарий
    Есть вопрос по vbWaitForMultipleObjects.
    Можешь, пожалуйста, посмотреть эту тему?
    Ответил.
    Запись от The trick размещена 09.12.2014 в 08:29 The trick на форуме
 
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.