dcsimg
Results 1 to 22 of 22

Thread: [VB6] - Class for waiting asynchronous kernel objects.

  1. #1

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    [VB6] - Class for waiting asynchronous kernel objects.

    Hello everyone! Developed a class for asynchronous waiting 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:
    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
    Last edited by The trick; Oct 9th, 2015 at 02:22 PM.

  2. #2

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    How does this work.
    Creates a window to receive notifications in the main thread. When you call the expectations created a new thread with the same name API function. When the function fulfills (for signal state, timeout or error), it sends a message to our window, which is treating it generates an event for the current object instance. All manipulations are done in assembly language, allowing to manage one class (without modules), to the same for all instances of the same code is used. Also made a small test in the IDE (in compiled form is not present), so you can stop with the "environment", press pause, without consequences (events simply will not be called). The only way to "crash" can occur if you start waiting, stop it using the Stop button (do not call the destructor). Then again start the IDE - if at this point will work an event from the past run - will crash because the object no longer exists.
    Code in assembler (NASM):
    Code:
    [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

  3. #3

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    Demonstration of monitoring the file operation.

    Demonstration of monitoring the file operation in the directory and the subdirectories (create new file, delete file, rename file):
    Code:
    ' // clsTrickWait - demonstration of monitoring the file operation.
    ' // © Krivous Anatolii Anatolevich (The trick), 2015
    
    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, _
                             ByRef lpBuffer As Any, _
                             ByVal nBufferLength As Long, _
                             ByVal bWatchSubTree As Long, _
                             ByVal dwNotifyFilter As Long, _
                             ByVal lpBytesReturned As Long, _
                             ByRef 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" ( _
                             ByRef Destination As Any, _
                             ByRef Source As Any, _
                             ByVal Length As Long) As Long
    Private Declare Function CloseHandle Lib "kernel32" ( _
                             ByVal hObject As Long) As Long
    
    Private Const INFINITE                      As Long = -1
    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 monitor  As clsTrickWait ' // Asynchronous waiter
    
    Dim hDirectory  As Long         ' // Handle of the monitored directory
    Dim hEvent      As Long         ' // Handle of the asynchronous event
    Dim bufEvent()  As Byte         ' // Buffer for the notifications
    Dim ovr         As OVERLAPPED   ' // Structure which allow to do the asynchronous monitoring
    
    
    Private Sub cmdMonitor_Click()
        
        ' // Check if already opened then stop
        If hDirectory Then
            ' // Abort the waiting
            monitor.Abort
            ' // Close the directory handle and the event handle
            CloseHandle hEvent:     hEvent = 0
            CloseHandle hDirectory: hDirectory = 0
            ' // Change caption on button
            cmdMonitor.Caption = "Start"
            Exit Sub
        End If
        
        ' // Open directory for the monitoring
        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 error occured then exit
        If hDirectory = INVALID_HANDLE_VALUE Then MsgBox "Error open directory", vbExclamation: Exit Sub
        ' // Creating the event for the notifications
        hEvent = CreateEvent(0, True, True, 0)
        ' // Handle error
        If hEvent = 0 Then
        
            CloseHandle hDirectory: hDirectory = 0
            MsgBox "Error create notify event", vbExclamation
            Exit Sub
            
        End If
        ' // Fill the OVERLAPPED structure for the asynchronous call
        ovr.hEvent = hEvent
        ' // Allocate the buffer for the notifications
        ReDim bufEvent(16383)
        ' // Start the monitor in the asynchronous mode
        If ReadDirectoryChanges(hDirectory, bufEvent(0), UBound(bufEvent) + 1, True, FILE_NOTIFY_CHANGE_FILE_NAME, 0, ovr, 0) = 0 Then
            ' // Handle error
            MsgBox "Error start monitor", vbExclamation
            CloseHandle hEvent:     hEvent = 0
            CloseHandle hDirectory: hDirectory = 0
            Exit Sub
            
        End If
        ' // Launch the asynchronous waiting
        monitor.vbWaitForSingleObject hEvent, INFINITE
        
        cmdMonitor.Caption = "Stop"
        lstMonitor.ListItems.Clear
        
    End Sub
    
    Private Sub Form_Load()
        Set monitor = New clsTrickWait
        txtMonitor = Environ("WINDIR")
    End Sub
    
    ' // Event occurs if the directory being changed by the file operation that have monitored
    Private Sub monitor_OnWait(ByVal Handle As Long, ByVal Result As Long)
        Dim notify  As FILE_NOTIFY_INFORMATION
        Dim idx     As Long
        Dim name    As String
        
        ' // Walk through the notifications buffer
        Do
            ' // Copy to the temporary structure
            memcpy notify, bufEvent(idx), Len(notify)
            ' // Retrive the file name
            name = Chr$(34) & Left$(notify.wcFileName, notify.dwFileNameLength \ 2) & Chr$(34)
            ' // Add to list
            With lstMonitor.ListItems.Add(, , lstMonitor.ListItems.count + 1)
            
                ' // Check the kind of the notification
                Select Case notify.dwAction
                Case FILE_ACTION_ADDED:             .SubItems(1) = "ADDED"              ' // File being added
                Case FILE_ACTION_REMOVED:           .SubItems(1) = "REMOVED"            ' // File being deleted
                Case FILE_ACTION_RENAMED_OLD_NAME:  .SubItems(1) = "RENAMED (old name)" ' // File being renamed, this is the old name"
                Case FILE_ACTION_RENAMED_NEW_NAME:  .SubItems(1) = "RENAMED (new name)" ' // File being renamed, this is the new name"
                End Select
                
                .SubItems(2) = name
                
            End With
    
            ' // Walk to the next entry
            idx = idx + notify.dwNextEntryOffset
            ' // Repeat while the notifications exists
        Loop While notify.dwNextEntryOffset
        ' // Reset event
        ResetEvent Handle
        ' // Fill again the OVERLAPPED structure for the asynchronous call
        ovr.hEvent = Handle
        ' // Start the monitor in the asynchronous mode
        Call ReadDirectoryChanges(hDirectory, bufEvent(0), UBound(bufEvent) + 1, False, FILE_NOTIFY_CHANGE_FILE_NAME, 0, ovr, 0)
        ' // Abort the previous waiting
        monitor.Abort
        ' // Launch new
        monitor.vbWaitForSingleObject Handle, INFINITE
    
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
        ' // Abort the waiting
        monitor.Abort
        ' // If the monitoring is active then abort the process
        If hDirectory Then
            CancelIo hDirectory
        End If
        ' // Close all handles
        CloseHandle hDirectory
        CloseHandle hEvent
    End Sub
    Attached Files Attached Files
    Last edited by The trick; Oct 9th, 2015 at 02:26 PM.

  4. #4

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    Demonstration of waiting for the end of the process.

    Demonstration of waiting for the end of the process:
    Code:
    ' // clsTrickWait - demonstration of waiting for the end of the process.
    ' // © Krivous Anatolii Anatolevich (The trick), 2015
    
    Option Explicit
    
    Private Declare Function OpenProcess Lib "kernel32" ( _
                             ByVal dwDesiredAccess As Long, _
                             ByVal bInheritHandle As Long, _
                             ByVal dwProcessId As Long) As Long
    Private Declare Function CloseHandle Lib "kernel32" ( _
                             ByVal hObject As Long) As Long
    
    Private Const SYNCHRONIZE   As Long = &H100000
    Private Const INFINITE      As Long = -1
    
    Dim WithEvents proc As clsTrickWait ' // Asynchronous waiter
    
    Private Sub cmdRun_Click()
        Dim pid         As Long
        Dim hProcess    As Long
        
        ' // If already waiting
        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
        ' // Launch the process
        pid = Shell(txtProcess)
        ' // Open the process for the synchronization
        hProcess = OpenProcess(SYNCHRONIZE, False, pid)
    
        ' // Launch the asynchronous waiting
        proc.vbWaitForSingleObject hProcess, INFINITE
        
    End Sub
    
    Private Sub Form_Load()
        Set proc = New clsTrickWait
    End Sub
    
    ' // Event occurs when the process will end
    Private Sub proc_OnWait(ByVal Handle As Long, ByVal Result As Long)
    
        MsgBox "Process has ended." & vbNewLine & "Handle = " & Handle & vbNewLine & "Result = " & Result
        CloseHandle Handle
        
    End Sub
    Attached Files Attached Files

  5. #5

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    Demonstration of waiting for the waitable timer tick.

    Demonstration of waiting for the waitable timer tick. It may be useful for creating an alarm or other time-dependent things.
    Code:
    ' // clsTrickWait - demonstration of waiting for the waitable timer tick.
    ' // © Krivous Anatolii Anatolevich (The trick), 2015
    
    Option Explicit
    
    Private Declare Function CreateWaitableTimer Lib "kernel32" _
                             Alias "CreateWaitableTimerW" ( _
                             ByRef 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, _
                             ByRef lpSystemTime As Any) As Long
    Private Declare Function SystemTimeToFileTime Lib "kernel32" ( _
                             ByRef st As Any, _
                             ByRef ft As Currency) As Long
    Private Declare Function LocalFileTimeToFileTime Lib "kernel32" ( _
                             ByRef lpLocalFileTime As Currency, _
                             ByRef lpFileTime As Currency) As Long
    
    Dim WithEvents tmr  As clsTrickWait ' // Asynchronous waiter
    Dim hTimer          As Long         ' // Handle of the waitable timer
    
    Private Const INFINITE  As Long = -1
    
    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
        
        ' // To system time
        Dat = CDate(txtTimeClock)
        VariantTimeToSystemTime Dat, st(0)
        SystemTimeToFileTime st(0), lt
        LocalFileTimeToFileTime lt, ft
        ' // Set the waitable timer
        SetWaitableTimer hTimer, VarPtr(ft), 0, 0, 0, 0
        ' // If already waiting
        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
        ' // Launch the waiting
        tmr.vbWaitForSingleObject hTimer, INFINITE
        Exit Sub
        
    Cancel:
        
        MsgBox "Error", vbExclamation
        
    End Sub
    
    ' // Event occurs after the tick of the waitable timer
    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
        ' // Create the waitable timer
        hTimer = CreateWaitableTimer(ByVal 0&, False, 0)
        ' // Default - the current time
        txtTimeClock = Now
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
        CloseHandle hTimer
    End Sub
    Attached Files Attached Files

  6. #6
    Lively Member
    Join Date
    Oct 2008
    Posts
    111

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    Hi
    in your class i see a function
    Code:
    Function vbWaitForMultipleObjects
    When you use this function?

    For WaitableTimer: you need to create multiple instances of the same class for handle multiple timer events?

  7. #7

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    Quote Originally Posted by Nanni View Post
    Hi
    in your class i see a function
    Code:
    Function vbWaitForMultipleObjects
    When you use this function?
    This function is the analog of WinAPI function WaitForMultipleObjects. This function waits for the multiple instances of kernel objects. You can control the behavior of function in order to wait for any object from the list or wait for all objects from the list.
    Quote Originally Posted by Nanni View Post
    For WaitableTimer: you need to create multiple instances of the same class for handle multiple timer events?
    Not necessary. You can either create the multiple instances for each event or create the single instance and wait them by vbWaitForMultipleObjects. Just create the array of the handles and pass it (more precisely the address of the first element) to the second parameter of the method.

  8. #8
    Lively Member
    Join Date
    Oct 2008
    Posts
    111

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    Hi
    I tweaked in this way:

    Code:
    Dim hTimer()          As Long
    Dim EventCount      As Long
    
    Private Sub Form_Load()
        Set tmr = New clsTrickWait
        EventCount = -1
     txtTimeClock = Now
    End Sub
    
    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
        
        ' // To system time
        Dat = CDate(txtTimeClock)
        VariantTimeToSystemTime Dat, st(0)
        SystemTimeToFileTime st(0), lt
        LocalFileTimeToFileTime lt, ft
        
        EventCount = EventCount + 1 
        
        ReDim Preserve hTimer(EventCount)
        
    '     // Create the waitable timer
        hTimer(EventCount) = CreateWaitableTimer(ByVal 0&, False, 0)
        
    ' // Set the waitable timer
        SetWaitableTimer hTimer(EventCount), VarPtr(ft), 0, 0, 0, 0
     Exit Sub
        
    Cancel:
        
        MsgBox "Error", vbExclamation
        
    End Sub
    
    Private Sub cmdArm_Click()
    tmr.vbWaitForMultipleObjects EventCount, hTimer(0), 0&, INFINITE
    End Sub
    ..but crash when I click cmdArm button

    I'm doing something wrong?

  9. #9

  10. #10
    Lively Member
    Join Date
    Oct 2008
    Posts
    111

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    Hi
    I made change in code
    Code:
    tmr.vbWaitForMultipleObjects NumEvent, VarPtr(hTimer(0)), 0&, INFINITE
    but always crash.
    Also looking at your class in
    Code:
    Public Function Abort
    I see only reference to
    Code:
    WaitForSingleObject
    If you want check, I have enclosed my test project.

    Thanks
    Attached Files Attached Files

  11. #11

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,364

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    Your error is:
    Code:
    Private Sub cmdArm_Click()
        tmr.vbWaitForMultipleObjects EventCount + 1, VarPtr(hTimer(0)), 0&, INFINITE
    End Sub
    I guess you don't understand the meaning of the WaitForMultipleObjects function.
    Look the small example:
    Code:
    Dim timersCount      As Long
    
    Private Sub Form_Load()
        Dim i As Long
        Dim d As Date
        
        Set tmr = New clsTrickWait
        
        ' // Add 10 timers with the difference at 5 seconds
        d = Now
        
        For i = 0 To 9
            d = DateAdd("s", 5, d)
            AddTimer d
        Next
        
        ' // Launch the waiting
        tmr.vbWaitForMultipleObjects timersCount, VarPtr(hTimer(0)), 0, INFINITE
        
    End Sub
    
    ' // This procedure add the timer to the array
    Private Sub AddTimer(datTime As Date)
        Dim st(8)   As Integer
        Dim ft      As Currency
        Dim lt      As Currency
        
        timersCount = timersCount + 1
        ReDim Preserve hTimer(timersCount - 1)
        hTimer(timersCount - 1) = CreateWaitableTimer(ByVal 0&, False, 0)
        VariantTimeToSystemTime datTime, st(0)
        SystemTimeToFileTime st(0), lt
        LocalFileTimeToFileTime lt, ft
        SetWaitableTimer hTimer(timersCount - 1), VarPtr(ft), 0, 0, 0, 0
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
        Dim i As Long
        For i = 0 To UBound(hTimer)
        CloseHandle hTimer(i)
        Next i
    End Sub
    
    ' // Event occurs after the tick of the waitable timer
    Private Sub tmr_OnWait(ByVal Handle As Long, ByVal Result As Long)
        
        If Result < timersCount And Result >= 0 Then
            ' // Remove timer from array, just send it to the end of the array and decrement number of timers
            Dim i As Long
            Dim t As Long
            
            timersCount = timersCount - 1
            t = hTimer(Result)
            
            For i = Result To timersCount - 1
                hTimer(i) = hTimer(i + 1)
            Next
            
            hTimer(timersCount) = t
            
        End If
        
        ' // Run wait again
        tmr.Abort
        tmr.vbWaitForMultipleObjects timersCount, VarPtr(hTimer(0)), 0, INFINITE
    
        MsgBox "Timer event." & vbNewLine & "Handle = " & t
        
    End Sub

  12. #12
    Lively Member
    Join Date
    Oct 2008
    Posts
    111

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    Hi
    Thanks for example.
    Now I have learned how to use WaitForMultipleObjects

  13. #13
    Member
    Join Date
    May 2013
    Posts
    47

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    Quote Originally Posted by The trick View Post
    Your error is:
    Code:
    Private Sub cmdArm_Click()
        tmr.vbWaitForMultipleObjects EventCount + 1, VarPtr(hTimer(0)), 0&, INFINITE
    End Sub
    I guess you don't understand the meaning of the WaitForMultipleObjects function.
    Look the small example:
    Code:
    Dim timersCount      As Long
    
    Private Sub Form_Load()
        Dim i As Long
        Dim d As Date
        
        Set tmr = New clsTrickWait
        
        ' // Add 10 timers with the difference at 5 seconds
        d = Now
        
        For i = 0 To 9
            d = DateAdd("s", 5, d)
            AddTimer d
        Next
        
        ' // Launch the waiting
        tmr.vbWaitForMultipleObjects timersCount, VarPtr(hTimer(0)), 0, INFINITE
        
    End Sub
    
    ' // This procedure add the timer to the array
    Private Sub AddTimer(datTime As Date)
        Dim st(8)   As Integer
        Dim ft      As Currency
        Dim lt      As Currency
        
        timersCount = timersCount + 1
        ReDim Preserve hTimer(timersCount - 1)
        hTimer(timersCount - 1) = CreateWaitableTimer(ByVal 0&, False, 0)
        VariantTimeToSystemTime datTime, st(0)
        SystemTimeToFileTime st(0), lt
        LocalFileTimeToFileTime lt, ft
        SetWaitableTimer hTimer(timersCount - 1), VarPtr(ft), 0, 0, 0, 0
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
        Dim i As Long
        For i = 0 To UBound(hTimer)
        CloseHandle hTimer(i)
        Next i
    End Sub
    
    ' // Event occurs after the tick of the waitable timer
    Private Sub tmr_OnWait(ByVal Handle As Long, ByVal Result As Long)
        
        If Result < timersCount And Result >= 0 Then
            ' // Remove timer from array, just send it to the end of the array and decrement number of timers
            Dim i As Long
            Dim t As Long
            
            timersCount = timersCount - 1
            t = hTimer(Result)
            
            For i = Result To timersCount - 1
                hTimer(i) = hTimer(i + 1)
            Next
            
            hTimer(timersCount) = t
            
        End If
        
        ' // Run wait again
        tmr.Abort
        tmr.vbWaitForMultipleObjects timersCount, VarPtr(hTimer(0)), 0, INFINITE
    
        MsgBox "Timer event." & vbNewLine & "Handle = " & t
        
    End Sub
    have some questions
    “If Result < timersCount And Result >= 0 Then”
    result always > timersCount?Name:  a.png
Views: 2014
Size:  27.7 KB
    how error?

  14. #14

  15. #15
    Member
    Join Date
    May 2013
    Posts
    47

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    because 258,can not changed,how can load if~end if function code

  16. #16
    Member
    Join Date
    May 2013
    Posts
    47

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    Name:  QQ图片20151019102350.jpg
Views: 1880
Size:  27.6 KB

  17. #17

  18. #18
    Member
    Join Date
    May 2013
    Posts
    47

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    the code is you
    Dim timersCount As Long

    Private Sub Form_Load()
    Dim i As Long
    Dim d As Date

    Set tmr = New clsTrickWait

    ' // Add 10 timers with the difference at 5 seconds
    d = Now

    For i = 0 To 9
    d = DateAdd("s", 5, d)
    AddTimer d
    Next

    ' // Launch the waiting
    tmr.vbWaitForMultipleObjects timersCount, VarPtr(hTimer(0)), 0, INFINITE

    End Sub

    ' // This procedure add the timer to the array
    Private Sub AddTimer(datTime As Date)
    Dim st(8) As Integer
    Dim ft As Currency
    Dim lt As Currency

    timersCount = timersCount + 1
    ReDim Preserve hTimer(timersCount - 1)
    hTimer(timersCount - 1) = CreateWaitableTimer(ByVal 0&, False, 0)
    VariantTimeToSystemTime datTime, st(0)
    SystemTimeToFileTime st(0), lt
    LocalFileTimeToFileTime lt, ft
    SetWaitableTimer hTimer(timersCount - 1), VarPtr(ft), 0, 0, 0, 0
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
    Dim i As Long
    For i = 0 To UBound(hTimer)
    CloseHandle hTimer(i)
    Next i
    End Sub

    ' // Event occurs after the tick of the waitable timer
    Private Sub tmr_OnWait(ByVal Handle As Long, ByVal Result As Long)

    If Result < timersCount And Result >= 0 Then
    ' // Remove timer from array, just send it to the end of the array and decrement number of timers
    Dim i As Long
    Dim t As Long

    timersCount = timersCount - 1
    t = hTimer(Result)

    For i = Result To timersCount - 1
    hTimer(i) = hTimer(i + 1)
    Next

    hTimer(timersCount) = t

    End If

    ' // Run wait again
    tmr.Abort
    tmr.vbWaitForMultipleObjects timersCount, VarPtr(hTimer(0)), 0, INFINITE

    MsgBox "Timer event." & vbNewLine & "Handle = " & t

    End Sub

  19. #19
    Member
    Join Date
    May 2013
    Posts
    47

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    if i used this code in IDE,have no error ,but if i make the code tO exe,the error can happen
    d = DateAdd("s", 5, d)
    AddTimer d
    Next

  20. #20
    Member
    Join Date
    Feb 2006
    Posts
    63

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    I use clsTrickWait.cls to monitoring the file operation in a folder but i have a problem.....

    1. Start folder monitor
    2. Start Copy a very large file to folder
    3. Event FILE_ACTION_ADDED appear when file start to write on disk.
    4. After a time finish copying file (write on disk finish)
    5. .......HOW CAN I DETECT MOMENT WHEN FILE FINISHING COPY (WRITE DO DISK).....?

  21. #21

  22. #22
    Member
    Join Date
    Feb 2006
    Posts
    63

    Re: [VB6] - Class for waiting asynchronous kernel objects.

    Quote Originally Posted by The trick View Post
    Also you should use the FILE_NOTIFY_CHANGE_LAST_WRITE flag in ReadDirectoryChangesW.

    ... Thanks and i found this...
    https://www.desaware.com/tech/filemonitoring.aspx
    Last edited by cliv; Jan 22nd, 2016 at 02:22 AM.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width