threadcontrol.cls

VB圣经

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)
'   Files:
'     ThreadData.cls
'     ThreadLaunch.cls
'     ThreadProc.bas
'   Minimal VBoost conditionals:
'     None
'   Conditional Compilation Values:
'     None
'
' 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_EventHandle As Long            'Synchronization handle
Private m_CS As 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 InputData 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 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 TPD As ThreadProcData
Dim ThreadID As Long
Dim ThreadHandle As Long
Dim fCleanUpOnFailure As Boolean
Dim hProcess As Long
Dim pThreadData As Long
    CleanCompletedThreads 'We need to clean up sometime, this is as good a time as any
    pThreadData = NewThreadData
    With TPD
        .CLSID = CLSID
        .EventHandle = m_EventHandle
        .pCritSect = m_pCS
        modThreadData.SetData pThreadData, InputData, fStealInputData, fKeepOutputData
        Set modThreadData.Controller(pThreadData) = Me
        'TB is the first member in ThreadData
        .pThreadBridge = pThreadData
        m_RunningThreads.Add pThreadData, CStr(pThreadData)
    End With
    If fKeepOutputData Then
        OutputDataCookie = pThreadData
    End If
    ThreadHandle = CreateThread(0, 0, AddressOf ThreadProc.ThreadStart, VarPtr(TPD), 0, ThreadID)
    If ThreadHandle = 0 Then
        fCleanUpOnFailure = True
    Else
        'Turn ownership of the thread handle over to
        'the ThreadData object
        modThreadData.ThreadHandle(pThreadData) = ThreadHandle
        'Make sure we've been notified by ThreadProc before continuing to
        'guarantee that the new thread has gotten the data they need out
        'of the ThreadProcData structure
        WaitForSingleObject m_EventHandle, INFINITE
        If TPD.hr Then
            fCleanUpOnFailure = True
        ElseIf fReturnThreadHandle Then
            hProcess = GetCurrentProcess
            DuplicateHandle hProcess, ThreadHandle, hProcess, CreateWorkerThread
        End If
    End If
    If fCleanUpOnFailure Then
        'Tell the thread its done using the normal mechanism
        'ThreadDone is the first field in ThreadBridge
        InterlockedIncrement TPD.pThreadBridge
        'There's no reason to keep the new thread data
        CleanCompletedThreads
    End If
    If TPD.hr Then Err.Raise TPD.hr
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.
Friend Function GetWorkerOutput(ByVal OutputDataCookie 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, 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_EventHandle = CreateEvent(0, 0, 0, vbNullString)
    If m_EventHandle = 0 Then
        Err.Raise &H80070000 + Err.LastDllError
    End If
    m_pCS = VarPtr(m_CS)
    InitializeCriticalSection m_pCS
End Sub

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