threadproc.bas

此源码为vb圣经编码

Attribute VB_Name = "ThreadProc"
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'
' You are entitled to license free distribution of any application
'   that uses this file if you own a copy of the book, or if you
'   have obtained the file from a source approved by the author. You
'   may redistribute this file only with express written permission
'   of the author.
'
' This file depends on:
'   References:
'     VBoostTypes6.olb (VBoost Object Types (6.0))
'     ThreadAPI.olb (VBoost: API declares used for threading)
'   Files:
'     ThreadControl.cls
'     ThreadData.cls
'     ThreadLaunch.cls
'   Minimal VBoost conditionals:
'     None
'   Conditional Compilation Values:
'     None
'
' This file is discussed in Chapter 13.
'***************************************************************
Option Explicit
Public Type ThreadBridge
    ThreadDone As Long    'Increment on completion (keep first)
    InputData As Variant  'Incoming data
    OutputData As Variant 'Outgoing data
    ThreadSignalPtr As Long 'Set to worker's signal pointer
    fSignaled As Boolean  'TB.ThreadSignalPtr is incremented
End Type
Public Type ThreadData
    TB As ThreadBridge     'For ThreadProc (keep first)
    fKeepData As Boolean  'Cache after completion
    ExitCode As Long      'The threads exit code
    ThreadHandle As Long        'Handle to the current thread
    Controller As ThreadControl 'Reference to controller
End Type
Public Type ThreadProcData
    EventHandle As Long
    CLSID As CLSID
    hr As Long
    pCritSect As Long
    pThreadBridge As Long  'Pointer to ThreadBridge structure
End Type
Private Const FailBit As Long = &H80000000
Public Function ThreadStart(ThreadProcData As ThreadProcData) As Long
Dim hr As Long
Dim pUnk As IUnknown
Dim TL As ThreadLaunch
Dim IID_IUnknown As VBGUID
Dim pCritSect As Long
Dim SAFTB As SafeArray1d
Dim TB() As ThreadBridge
Dim pFTB As Long
    'Extreme care must be taken in this function to
    'not do any real VB code until an object has been
    'created on this thread by VB.
    hr = CoInitialize(0)
    With ThreadProcData
        If hr And FailBit Then
            .hr = hr
            PulseEvent .EventHandle
            Exit Function
        End If
        With IID_IUnknown
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        hr = CoCreateInstance(.CLSID, Nothing, CLSCTX_INPROC_SERVER, IID_IUnknown, pUnk)
        If hr And FailBit Then
            .hr = hr
            PulseEvent .EventHandle
            CoUninitialize
            Exit Function
        End If
        
        'If we made it this far, then we can start using normal VB calls
        'because we have an initialized object on this thread
        On Error Resume Next
        Set TL = pUnk
        Set pUnk = Nothing
        If Err Then
            .hr = Err
            PulseEvent .EventHandle
            CoUninitialize
            Exit Function
        End If
        pFTB = VarPtrArray(TB)
        With SAFTB
            .cDims = 1
            .cbElements = LenB(TB(0))
            .cElements = 1
            .pvData = ThreadProcData.pThreadBridge
        End With
        CopyMemory ByVal pFTB, VarPtr(SAFTB), 4
        pCritSect = .pCritSect
        'The controlling thread can continue at this point.
        'The event must be pulsed here because CoGetInterfaceAndReleaseStream
        'blocks if WaitForSingleObject is still running.
        PulseEvent .EventHandle
        
        'Launch the background thread and wait for it to finish.
        With TB(0)
            ThreadStart = TL.Go(.InputData, .OutputData, .ThreadSignalPtr)
        End With
        
        'Tell the controlling thread that this thread is done.
        EnterCriticalSection pCritSect
        TB(0).ThreadDone = 1
        LeaveCriticalSection pCritSect
        
        'Clear the array before we leave here
        CopyMemory ByVal pFTB, 0&, 4
        
        'Release TL after the critical section. This
        'prevents ThreadData.SignalThread from
        'signalling a pointer to released memory.
        Set TL = Nothing
    End With
    CoUninitialize
End Function