ThreadControl.cls #1

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ThreadControl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'***************************************************************
' (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)
'     VBoost6.Dll (VBoost Object Implementation (6.0)) (optional)
'   Files:
'     ThreadData.bas
'     ThreadLaunch.cls
'     ThreadProc.bas
'     VBoost.bas
'   Minimal VBoost conditionals:
'     VBOOST_INTERNAL = 1 : VBOOST_CUSTOM = 1
'   Conditional Compilation Values:
'     NOVBOOST = 1 'Removes VBoost.bas dependency
'
' This file is discussed in Chapter 13.
'***************************************************************
Option Explicit
Private m_RunningThreads As Collection   'Collection to hold ThreadData objects for each running thread
Private m_FinishedThreads As Collection  'Collection to hold ThreadData objects for each finished thread
Private m_CS As ThreadingAPIs.CRITICAL_SECTION 'Critical section to avoid conflicts when signalling threads
Private m_pCS As Long                    'Pointer to m_CS structure

'Called to create a new thread worker thread.
'CLSID can be obtained from a ProgID via CLSIDFromProgID
'InputData contains the data for the new thread. This
'  should never be an object reference.
'fKeepOutputData should be True if you want to retrieve
'  output data with GetWorkerOutput. This must be set for
'  a valid cookie to be returned in OutputDataCookie.
'OutputDataCookie retrieves a cookie that can be used
'  later to retrieve the exit code and output variant
'  from a completed worker thread.
'fStealInputData should be True if the data is large. If
'  this is set, then Data will be Empty on return.
'fReturnThreadHandle must explicitly be set to True to
'  return the created thread handle. This handle can be
'  used for calls like SetThreadPriority and must be
'  closed with CloseHandle.
Friend Function CreateWorkerThread(CLSID As VBoostTypes.CLSID, InputData As Variant, Optional ByVal fKeepOutputData As Boolean = False, Optional OutputDataCookie As Long, Optional ByVal fStealInputData As Boolean = False, Optional ByVal fReturnThreadHandle As Boolean = False) As Long
Dim InitThreadData As ThreadData
Dim ThreadID As Long
Dim ThreadHandle As Long
Dim hProcess As Long
Dim pThreadData As Long
Dim vt As Integer
    CleanCompletedThreads 'We need to clean up sometime, this is as good a time as any
    With InitThreadData
        .CLSID = CLSID
        .pCritSect = m_pCS
        Set .Controller = Me
        If fStealInputData Then
            'Disallow stealing VT_BYREF data
            VBoostTypes.CopyMemory vt, InputData, 2
            If vt And &H4000 Then GoTo DontSteal
            #If NOVBOOST Then
                VBoostTypes.CopyMemory ByVal VarPtr(.InputData), ByVal VarPtr(InputData), 16
                VBoostTypes.CopyMemory ByVal VarPtr(InputData), 0, 2
            #Else
                VBoost.MoveVariant .InputData, InputData
            #End If
        'ElseIf IsObject(Data) Then
            'Don't support this case, no objects allowed in data
        Else
DontSteal:
            .InputData = InputData
        End If
        .fKeepData = fKeepOutputData
    End With
    pThreadData = modThreadData.NewThreadData(InitThreadData)
    m_RunningThreads.Add pThreadData, CStr(pThreadData)
    If fKeepOutputData Then
        OutputDataCookie = pThreadData
    End If
    ThreadHandle = ThreadingAPIs.CreateThread(0, 0, AddressOf ThreadProc.ThreadStart, pThreadData, 0, ThreadID)
    If ThreadHandle Then
        'Turn ownership of the thread handle over to
        'the ThreadData object
        modThreadData.ThreadHandle(pThreadData) = ThreadHandle
        If fReturnThreadHandle Then
            hProcess = ThreadingAPIs.GetCurrentProcess
            ThreadingAPIs.DuplicateHandle hProcess, ThreadHandle, hProcess, CreateWorkerThread
        End If
    End If
End Function

'Call StopWorkerThreads to signal all worker threads
'and spin until they terminate.
Friend Sub StopWorkerThreads()
    modThreadData.StopThreads m_RunningThreads, m_FinishedThreads, m_pCS
End Sub

'Releases ThreadData objects for all threads
'that are completed. Cleaning happens automatically
'when you call SignalWorkerThreads, StopWorkerThreads,
'and GetWorkerOutput.
Friend Sub CleanCompletedThreads(Optional ByVal fTossCompletedData As Boolean = False)
Dim Iter As Variant
    modThreadData.CleanThreads m_RunningThreads, m_FinishedThreads
    If fTossCompletedData Then
        With m_FinishedThreads
            Do While .Count
                modThreadData.DestroyThreadData .Item(1)
                .Remove 1
            Loop
        End With
    End If
End Sub

'Call to tell all running worker threads to
'terminate. If the thread hasn't set its
'ThreadSignalPtr yet, then it can't be signaled
'Unlike StopWorkerThreads, this does not block
'while the workers actually terminate.
'SignalWorkerThreads must be called by the owner
'of this class before the ThreadControl instance
'is released.
Friend Sub SignalWorkerThreads()
    modThreadData.SignalThreads m_RunningThreads, m_FinishedThreads, m_pCS
End Sub

'Call to retrieve the data and exit code from
'a worker thread launched with CreateWorkerThread.
'This will return False if the thread has not
'yet completed. You get one call to GetWorkerOutput
'for each cookie.
Friend Function GetWorkerOutput(ByVal OutputDataCookie As Long, hr As Long, ExitCode As Long, OutputData As Variant) As Boolean
Dim DataKey As String
    CleanCompletedThreads
    DataKey = CStr(OutputDataCookie)
    On Error Resume Next
    m_FinishedThreads.Item DataKey
    If Err Then
        On Error GoTo 0
        Exit Function
    End If
    On Error GoTo 0
    modThreadData.GetOutputData OutputDataCookie, hr, ExitCode, OutputData
    modThreadData.DestroyThreadData OutputDataCookie
    m_FinishedThreads.Remove DataKey
    GetWorkerOutput = True
End Function

Private Sub Class_Initialize()
    Set m_RunningThreads = New Collection
    Set m_FinishedThreads = New Collection
    m_pCS = VarPtr(m_CS)
    ThreadingAPIs.InitializeCriticalSection m_pCS
End Sub

Private Sub Class_Terminate()
    CleanCompletedThreads True              'Just in case, this generally only cleans completed data.
    If m_pCS Then ThreadingAPIs.DeleteCriticalSection m_pCS
End Sub