dcsimg
Results 1 to 22 of 22

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

Threaded View

  1. #1

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

    [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.

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