ThreadProc.bas #1

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.bas
'     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 ThreadData
    CLSID As VBoostTypes.CLSID 'CLSID to create (CT:W, WT:R)
    hr As Long           'An error code (WT:W, CT:R)
    pCritSect As Long    'Critical section pointer (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)
    OutputData As Variant 'Output from the worker (WT:W, CT: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)
    ExitCode As Long     'The thread's exit code  (CT:RW)
    ThreadHandle As Long 'Handle to the current thread (CT:RW)
    Controller As ThreadControl 'Reference to controller (CT:RW)
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 VBoostTypes.VBGUID
    '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 = ThreadingAPIs.CoInitialize(0)
        If .hr And FailBit Then
            .ThreadDone = 1
            Exit Function
        End If
        With IID_IUnknown
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        .hr = ThreadingAPIs.CoCreateInstance(.CLSID, Nothing, ThreadingAPIs.CLSCTX_INPROC_SERVER, IID_IUnknown, pUnk)
        If .hr And FailBit Then
            .ThreadDone = 1
            ThreadingAPIs.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
            .ThreadDone = 1
            ThreadingAPIs.CoUninitialize
            Exit Function
        End If
        
        'Launch the background thread and wait for it to finish
        ThreadStart = TL.Go(.InputData, .OutputData, .ThreadSignalPtr)
        
        .hr = Err
        
        'Tell the controlling thread that this thread is done.
        'Note that the critical section coordinates between
        'ThreadSignalPtr and ThreadDone. ThreadSignalPtr isn't
        'set until TL.Go, so we don't need a critical section
        'to increment ThreadDone until now.
        ThreadingAPIs.EnterCriticalSection .pCritSect
        .ThreadDone = 1
        ThreadingAPIs.LeaveCriticalSection .pCritSect
        
        'Release TL after the critical section. This
        'prevents ThreadData.SignalThread from
        'signalling a pointer to released memory.
        Set TL = Nothing
    End With
    ThreadingAPIs.CoUninitialize
End Function