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
'Key for ThreadData comments
' WT:R = Read by worker thread
' CT:W = Written by controlling thread
' CT:RW = Written and read by controlling thread
' WT:RW = Written and read by controlling thread

Public Type ThreadDataOutput
    hr As Long           'An error code (WT:W, CT:R) (keep first)
    ExitCode As Long     'The thread's exit code  (CT:RW)
    OutputData As Variant 'Output from the worker (WT:W, CT:R)
End Type
Public Type ThreadData
    CLSID As CLSID       'CLSID to create (CT:W, WT:R)
    ThreadDone As Long   'Increment on completion (WT:W, CT:R)
    InputData As Variant 'Input for the worker(CT:W, WT:R)
    ThreadSignalPtr As Long 'Pointer in worker (WT:W, CT:R)
    fSignaled As Boolean '*TB.ThreadSignalPtr changed (CT:RW)
    fKeepData As Boolean 'Cache output after completion (CT:RW)
    ThreadHandle As Long 'Handle to the current thread (CT:RW)
    Controller As ThreadControl 'Reference to controller (CT:RW)
    pRecycleEvent As Long 'Synchronization handle (CT:RW)
    pOutput As Long      'ThreadDataOutput pointer (CT:W, WT:R)
End Type
Private Const FailBit As Long = &H80000000
Public Function ThreadStart(ThreadData As ThreadData) As Long
Dim pUnk As IUnknown
Dim TL As ThreadLaunch
Dim IID_IUnknown As VBGUID
Dim SA1D As SafeArray1d
Dim pOutputData() As ThreadDataOutput
Dim hr 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.
    With ThreadData
        hr = CoInitialize(0)
        If hr And FailBit Then
            .ThreadDone = 1
            CopyMemory .pOutput, hr, 4
            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
            .ThreadDone = 1
            CopyMemory .pOutput, hr, 4
            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
            CopyMemory .pOutput, hr, 4
            .ThreadDone = 1
            CoUninitialize
            Exit Function
        End If
        
        'Launch the background thread and wait for it to finish
        With SA1D
            .cDims = 1
            .cElements = 1
            .cbElements = LenB(pOutputData(0))
        End With
        CopyMemory ByVal VarPtrArray(pOutputData), VarPtr(SA1D), 4
Recycle:
        SA1D.pvData = .pOutput
        With pOutputData(0)
            .ExitCode = TL.Go(ThreadData.InputData, _
              .OutputData, ThreadData.ThreadSignalPtr)
        
            .hr = Err
        End With
        
        'Flag this pass as done
        ThreadData.ThreadDone = 1
        
        'Wait until the event gets pulsed to enable us to
        'recycle our data. If .ThreadDone is still set
        'after we clear this event, then we should terminate.
        WaitForSingleObject .pRecycleEvent, INFINITE
        If .ThreadDone = 0 Then GoTo Recycle
        
        'Use VarPtrArray before releasing TL so that
        'the runtime is still with us.
        ZeroMemory ByVal VarPtrArray(pOutputData), 4
        
        Set TL = Nothing
    End With
    CoUninitialize
End Function