用API函数CreateThread: private declare function CreateThread Lib "kernel32" (byval pThreadAttributes as any, byval dwStackSize as long, byval lpStartAddress as long, lpParameter as any, byval dwCreationFlags as long, lpThreadID as long) as long
Easy multithreading with low overhead - Part 1Srideep Prasad posted an article on how to do safe multithreading in vb6 with multi instancing. His "solution" required making an activex exe and making new instances of it for each thread which obviously is very processor consuming and defeats the very purpose of multithreading. His reason for this "solution" was "hey, at least theres no more doevents." Give me a break. I'm dont understand how he code made it to code of the month list.My solution is simple and has low overhead.1. Create an api dll using visual c++. If you dont know how to program c++, thats no problem. You can use my template. 2. Make a function that gets the address of the function you want to run in a seperate thread. 3. From here you can either use the dll as code running in the background to serve as a "airbag" so you can call CreateThread safely from in the dll, or you can call the function by yourself in the dll by address. (This is called a callback routine. Many enumerated functions in the windows api do this.)Part 1 of this tutorial will cover how to make a callback routine for your multithreading.The first step is to make a new Win32 Dynamic-Link Library workspace. Here is my code template for an api dll.#include <windows.h> // This may be a little confusing to some people. // All this next line does is specify a vb-safe calling convention // CALLBACK* says that the variable type is actually a function, in this case a vb function // THREADED_FUNC is the variable type that the function will be called in the dll. I could have put anything else in here // typedef BOOL means that the function has a return value of boolean // (int) means that the function has one paramater and its an integer. You could put as many of these as you need, depending // on the number of parameters your function takes. ie your function takes an integer and two strings. You would put // (int, LPCSTR, LPCSTR) typedef BOOL (CALLBACK* THREADED_FUNC) (int); // Function prototypes void FreeProcessor(void); LONG __declspec(dllexport) WINAPI MakeThread(THREADED_FUNC &pTFunc, int nPassedValue); // Starting and ending point of the dll, required for every api dll extern "C" int APIENTRY DllMain(HINSTANCE hInstance, DWORD dwReason, LPVOID lpReserved) { if (dwReason == DLL_PROCESS_ATTACH) { // dll starts processing here // inital values and processing should go here
} else if (dwReason == DLL_PROCESS_DETACH) { // dll stops processing here // all clean up code should go here
} return 1; } // MakeThread - Function that calls function by address (This is the callback routine) // This function accepts a THREADED_FUNC which is actually the address of the threaded function // It also accepts the parameters your function takes which is an integer for this example. You will need to set the // number of parameters to match the function you wrote LONG __declspec(dllexport) WINAPI MakeThread(int nPassedValue, THREADED_FUNC &pTFunc) { // try-catch block for error handling try { do { // call the function by address and examin return value if (pTFunc(nPassedValue) == FALSE) return 1; FreeProcessor(); } while (true); } catch (int) { return 0; } } // FreeProcessor function written by Jared Bruni void FreeProcessor(void) { MSG Msg; while(PeekMessage(&Msg,NULL,0,0,PM_REMOVE)) { if (Msg.message == WM_QUIT)break; TranslateMessage(&Msg); DispatchMessage(&Msg); } } The next step is to create a export definitions file for MakeThread. This is very simple. LIBRARY MyFile DESCRIPTION 'Callback multithreading dll for MyProgram' CODE PRELOAD MOVEABLE DISCARDABLE DATA PRELOAD MOVEABLE SINGLEHEAPSIZE 4096 EXPORTS MakeThread @1 I highlighted the LIBRARY line for a good reason. Make sure whatever you type after LIBRARY is the name of the cpp file that your DllMain is in. For example if your DllMain is in a file called "BigLousyDll.cpp", then you would type LIBRARY BigLousyDllAlso make sure that the export definitions file is the same name as the cpp file your DllMain is in. Like I said, if your DllMain is in a file called "BigLousyDll.cpp", you would name your export definitions file BigLousyDll.defOnce you compile your dll, it should automatically be registered. I would put it in your system or system32 folder so you don't have to type a explicit path to it in your vb file.Public Declare Function MakeThread Lib "MyFile.dll" (lpCallback As Any, ByVal nInt As Integer) As Long Public i As Integer Public nTimes As IntegerPublic Function MyFunction(ByVal nValue As Integer) As Boolean nTimes = nTimes + 1 If nTimes > 0 Then If i < 20 Then i = i + 1 End If MyFunction = True 'Tells dll to keep running through function Exit Function Else i = nValue MyFunction = True 'Tells dll to keep running through function Exit Function End If MyFunction = False 'Tells dll to stop End Function Sub Main() If Not MakeThread(AddressOf MyFunction, 3) Then MsgBox "Multithreading error" Else MsgBox "Success" End If End Sub If you find this code helpful, vote only if you want to. I dont care if I win coding contest. I just thought this solution is excellent compared to what Srideep Prasad posted. Easy, Stable VB6 Multithreading with Low Overhead - Part 2 Calling CreateThread Safely Within a DLLI found some better, straight vb code for the tutorial I was going to do for this part so I thought it would be better than using c++. The code does the same thing.Part 2 of thesse tutorials is based off Matthew Curland's "Apartment Threading in VB6, Safely and Externally". This uses a precompiled type library to easily call CreateThread from a global name space (no declaration required). While this might be use activex, it still isn't using nearly as many system resources as Srideep's solution.In addition to safely calling CreateThread from vb there are some thread classes that are used for doing the work with class ids rather than function addresses. (Launch, Worker, ThreadControl, ThreadData, and ThreadLaunch)I will list all the classes below. I also decide4d not to add syntax highlighting because that took too long. Also please realize that I did not write these. Matthew Curland did. So vote for him, not me.ThreadControl.cls Option Explicit Private m_RunningThreads As Collection'Collection to hold ThreadData objects for each thread Private m_fStoppingWorkers As Boolean'Currently tearing down, so don't start anything new 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 th ' read. 'CLSID can be obtained from a ProgID via ' CLSIDFromProgID 'Data contains the data for the new thre ' ad 'fStealData should be True if the data i ' s large. If this ' is set, then Data will be Empty on ret ' urn. If Data ' contains an object reference, then the ' object should ' be created on this thread. '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, Data As Variant, Optional ByVal fStealData As Boolean = False, Optional ByVal fReturnThreadHandle As Boolean = False) As Long Dim TPD As ThreadProcData Dim IID_IUnknown As VBGUID Dim ThreadID As Long Dim ThreadHandle As Long Dim pStream As IUnknown Dim ThreadData As ThreadData Dim fCleanUpOnFailure As Boolean Dim hProcess As Long Dim pUnk As IUnknown If m_fStoppingWorkers Then Err.Raise 5, , "Can't create new worker while shutting down" CleanCompletedThreads 'We need to clean up sometime, this is as good a time as any With TPD Set ThreadData = New ThreadData .CLSID = CLSID .EventHandle = m_EventHandle With IID_IUnknown .Data4(0) = &HC0 .Data4(7) = &H46 End With .pMarshalStream = CoMarshalInterThreadInterfaceInStream(IID_IUnknown, Me) .ThreadDonePointer = ThreadData.ThreadDonePointer .ThreadDataCookie = ObjPtr(ThreadData) .pCritSect = m_pCS ThreadData.SetData Data, fStealData Set ThreadData.Controller = Me m_RunningThreads.Add ThreadData, CStr(.ThreadDataCookie) End With ThreadHandle = CreateThread(0, 0, AddressOf ThreadProc.ThreadStart, VarPtr(TPD), 0, ThreadID) If ThreadHandle = 0 Then fCleanUpOnFailure = True Else 'Turn ownership of the thread handle ove ' r to 'the ThreadData object ThreadData.ThreadHandle = ThreadHandle 'Make sure we've been notified by Thread ' Proc before continuing to 'guarantee that the new thread has gotte ' n 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 'Failure, clean up stream by making a re ' ference and releasing it CopyMemory pStream, TPD.pMarshalStream, 4 Set pStream = Nothing 'Tell the thread its done using the norm ' al mechanism InterlockedIncrement TPD.ThreadDonePointer 'There's no reason to keep the new threa ' d data CleanCompletedThreads End If If TPD.hr Then Err.Raise TPD.hr End Function 'Called after a thread is created to pro ' vide a mechanism 'to stop execution and retrieve initial ' data for running 'the thread. Should be called in ThreadL ' aunch_Go with: 'Controller.RegisterNewThread ThreadData ' Cookie, VarPtr(m_Notify), Controller, Da ' ta Public Sub RegisterNewThread(ByVal ThreadDataCookie As Long, ByVal ThreadSignalPointer As Long, ByRef ThreadControl As ThreadControl, Optional Data As Variant) Dim ThreadData As ThreadData Dim fInCriticalSection As Boolean Set ThreadData = m_RunningThreads(CStr(ThreadDataCookie)) ThreadData.ThreadSignalPointer = ThreadSignalPointer ThreadData.GetData Data 'The new thread should not own the contr ' olling thread because 'the controlling thread has to teardown ' after all of the worker 'threads are done running code, which ca ' n't happen if we happen 'to release the last reference to Thread ' Control in a worker 'thread. ThreadData is already holding a ' n extra reference on 'this object, so it is guaranteed to rem ' ain alive until 'ThreadData is signalled. Set ThreadControl = Nothing If m_fStoppingWorkers Then 'This will only happen when StopWorkerTh ' reads is called 'almost immediately after CreateWorkerTh ' read. We could 'just let this signal happen in the Stop ' WorkerThreads loop, 'but this allows a worker thread to be s ' ignalled immediately. 'See note in SignalThread about Critical ' Section usage. ThreadData.SignalThread m_pCS, fInCriticalSection If fInCriticalSection Then LeaveCriticalSection m_pCS End If End Sub 'Call StopWorkerThreads to signal all wo ' rker threads 'and spin until they terminate. Any call ' s to an object 'passed via the Data parameter in Create ' WorkerThread 'will succeed. Friend Sub StopWorkerThreads() Dim ThreadData As ThreadData Dim fInCriticalSection As Boolean Dim fSignal As Boolean Dim fHaveOleThreadhWnd As Boolean Dim OleThreadhWnd As Long If m_fStoppingWorkers Then Exit Sub m_fStoppingWorkers = True fSignal = True Do For Each ThreadData In m_RunningThreads If ThreadData.ThreadCompleted Then m_RunningThreads.Remove CStr(ObjPtr(ThreadData)) ElseIf fSignal Then 'See note in SignalThread about Critical ' Section usage. ThreadData.SignalThread m_pCS, fInCriticalSection End If Next If fInCriticalSection Then LeaveCriticalSection m_pCS fInCriticalSection = False Else 'We can turn this off indefinitely becau ' se new threads 'which arrive at RegisterNewThread while ' stopping workers 'are signalled immediately fSignal = False End If If m_RunningThreads.Count = 0 Then Exit Do 'We need to clear the message queue here ' in order to allow 'any pending RegisterNewThread messages ' to come through. If Not fHaveOleThreadhWnd Then OleThreadhWnd = FindOLEhWnd fHaveOleThreadhWnd = True End If SpinOlehWnd OleThreadhWnd, False Sleep 0 Loop m_fStoppingWorkers = False End Sub 'Releases ThreadData objects for all thr ' eads 'that are completed. Cleaning happens au ' tomatically 'when you call SignalWorkerThreads, Stop ' WorkerThreads, 'and RegisterNewThread. Friend Sub CleanCompletedThreads() Dim ThreadData As ThreadData For Each ThreadData In m_RunningThreads If ThreadData.ThreadCompleted Then m_RunningThreads.Remove CStr(ObjPtr(ThreadData)) End If Next End Sub 'Call to tell all running worker threads ' to 'terminated. If the thread has not yet c ' alled 'RegisterNewThread, then it will not be ' signalled. 'Unlike StopWorkerThreads, this does not ' block 'while the workers actually terminate. 'SignalWorkerThreads must be called by t ' he owner 'of this class before the ThreadControl ' instance 'is released. Friend Sub SignalWorkerThreads() Dim ThreadData As ThreadData Dim fInCriticalSection As Boolean For Each ThreadData In m_RunningThreads If ThreadData.ThreadCompleted Then m_RunningThreads.Remove CStr(ObjPtr(ThreadData)) Else 'See note in SignalThread about Critical ' Section usage. ThreadData.SignalThread m_pCS, fInCriticalSection End If Next If fInCriticalSection Then LeaveCriticalSection m_pCS End Sub Private Sub Class_Initialize() Set m_RunningThreads = New Collection m_EventHandle = CreateEvent(0, 0, 0, vbNullString) m_pCS = VarPtr(m_CS) InitializeCriticalSection m_pCS End Sub Private Sub Class_Terminate() CleanCompletedThreads'Just in case, this generally does nothing. Debug.Assert m_RunningThreads.Count = 0 'Each worker should have a reference to this class CloseHandle m_EventHandle DeleteCriticalSection m_pCS End Sub Launch.cls Option Explicit Private Controller As ThreadControl Public Sub LaunchThreads() Dim CLSID As CLSID CLSID = CLSIDFromProgID("DllThreads.Worker") Controller.CreateWorkerThread CLSID, 3000, True Controller.CreateWorkerThread CLSID, 5000, True Controller.CreateWorkerThread CLSID, 7000 End Sub Public Sub FinishThreads() Controller.StopWorkerThreads End Sub Public Sub CleanCompletedThreads() Controller.CleanCompletedThreads End Sub Private Sub Class_Initialize() Set Controller = New ThreadControl End Sub Private Sub Class_Terminate() Controller.StopWorkerThreads Set Controller = Nothing End Sub
ThreadLaunch.cls Option Explicit 'Just an interface definition Public Function Go(Controller As ThreadControl, ByVal ThreadDataCookie As Long) As Long End Function 'The rest of this is a comment #If False Then 'A worker thread should include the foll ' owing code. 'The Instancing for a worker should be s ' et to 5 - MultiUse Implements ThreadLaunch Private m_Notify As Long Public Function ThreadLaunch_Go(Controller As ThreadControl, ByVal ThreadDataCookie As Long) As Long Dim Data As Variant Controller.RegisterNewThread ThreadDataCookie, VarPtr(m_Notify), Controller, Data 'TODO: Process Data while 'regularly calling HaveBeenNotified to 'see if the thread should terminate. If HaveBeenNotified Then 'Clean up and return End If End Function Private Function HaveBeenNotified() As Boolean HaveBeenNotified = m_Notify End Function #End If
Worker.cls Option Explicit Implements ThreadLaunch Private m_Notify As Long Public Function ThreadLaunch_Go(Controller As ThreadControl, ByVal ThreadDataCookie As Long) As Long Dim Data As Variant Dim SleepTime As Long Controller.RegisterNewThread ThreadDataCookie, VarPtr(m_Notify), Controller, Data ThreadLaunch_Go = Data SleepTime = Data While SleepTime > 0 Sleep 100 SleepTime = SleepTime - 100 If HaveBeenNotified Then MsgBox "Notified" Exit Function End If Wend MsgBox "Done Sleeping: " & Data End Function Private Function HaveBeenNotified() As Boolean HaveBeenNotified = m_Notify End Function
ThreadData.cls Option Explicit Private m_ThreadDone As Long Private m_ThreadSignal As Long Private m_ThreadHandle As Long Private m_Data As Variant Private m_Controller As ThreadControl Friend Function ThreadCompleted() As Boolean Dim ExitCode As Long ThreadCompleted = m_ThreadDone If ThreadCompleted Then 'Since code runs on the worker thread af ' ter the 'ThreadDone pointer is incremented, ther ' e is a chance 'that we are signalled, but the thread h ' asn't yet 'terminated. In this case, just claim we ' aren't done 'yet to make sure that code on all worke ' r threads is 'actually completed before ThreadControl ' terminates. If m_ThreadHandle Then If GetExitCodeThread(m_ThreadHandle, ExitCode) Then If ExitCode = STILL_ACTIVE Then ThreadCompleted = False Exit Function End If End If CloseHandle m_ThreadHandle m_ThreadHandle = 0 End If End If End Function Friend Property Get ThreadDonePointer() As Long ThreadDonePointer = VarPtr(m_ThreadDone) End Property Friend Property Let ThreadSignalPointer(ByVal RHS As Long) m_ThreadSignal = RHS End Property Friend Property Let ThreadHandle(ByVal RHS As Long) 'This takes over ownership of the Thread ' Handle m_ThreadHandle = RHS End Property Friend Sub SignalThread(ByVal pCritSect As Long, ByRef fInCriticalSection As Boolean) 'm_ThreadDone and m_ThreadSignal must be ' checked/modified inside 'a critical section because m_ThreadDone ' could change on some 'threads while we are signalling, causin ' g m_ThreadSignal to point 'to invalid memory, as well as other pro ' blems. The parameters to this 'function are provided to ensure that th ' e critical section is entered 'only when necessary. If fInCriticalSect ' ion is set, then the caller 'must call LeaveCriticalSection on pCrit ' Sect. This is left up to the 'caller since this function is designed ' to be called on multiple instances 'in a tight loop. There is no point in r ' epeatedly entering/leaving the 'critical section. If m_ThreadSignal Then If Not fInCriticalSection Then EnterCriticalSection pCritSect fInCriticalSection = True End If If m_ThreadDone = 0 Then InterlockedIncrement m_ThreadSignal End If 'No point in signalling twice m_ThreadSignal = 0 End If End Sub Friend Property Set Controller(ByVal RHS As ThreadControl) Set m_Controller = RHS End Property Friend Sub SetData(Data As Variant, ByVal fStealData As Boolean) If IsEmpty(Data) Or IsMissing(Data) Then Exit Sub If fStealData Then CopyMemory ByVal VarPtr(m_Data), ByVal VarPtr(Data), 16 CopyMemory ByVal VarPtr(Data), 0, 2 ElseIf IsObject(Data) Then Set m_Data = Data Else m_Data = Data End If End Sub Friend Sub GetData(Data As Variant) 'This is called only once. Always steal. ' 'Before stealing, make sure there's 'nothing lurking in Data Data = Empty CopyMemory ByVal VarPtr(Data), ByVal VarPtr(m_Data), 16 CopyMemory ByVal VarPtr(m_Data), 0, 2 End Sub Private Sub Class_Terminate() 'This shouldn't happen, but just in case ' If m_ThreadHandle Then CloseHandle m_ThreadHandle End Sub
我说明白点吧。其实碰到一个这个情况。我要调用一个涵数。这有可能会造成程序停滞。
我想让它在执行时。也不会造成停滞。不要告诉我用什么DOEVENTS这些方法没用。
private declare function CreateThread Lib "kernel32" (byval pThreadAttributes as any, byval dwStackSize as long, byval lpStartAddress as long, lpParameter as any, byval dwCreationFlags as long, lpThreadID as long) as long
2. Make a function that gets the address of the function you want to run in a seperate thread.
3. From here you can either use the dll as code running in the background to serve as a "airbag" so you can call CreateThread safely from in the dll, or you can call the function by yourself in the dll by address. (This is called a callback routine. Many enumerated functions in the windows api do this.)Part 1 of this tutorial will cover how to make a callback routine for your multithreading.The first step is to make a new Win32 Dynamic-Link Library workspace. Here is my code template for an api dll.#include <windows.h>
// This may be a little confusing to some people.
// All this next line does is specify a vb-safe calling convention
// CALLBACK* says that the variable type is actually a function, in this case a vb function
// THREADED_FUNC is the variable type that the function will be called in the dll. I could have put anything else in here
// typedef BOOL means that the function has a return value of boolean
// (int) means that the function has one paramater and its an integer. You could put as many of these as you need, depending
// on the number of parameters your function takes. ie your function takes an integer and two strings. You would put
// (int, LPCSTR, LPCSTR)
typedef BOOL (CALLBACK* THREADED_FUNC) (int);
// Function prototypes
void FreeProcessor(void);
LONG __declspec(dllexport) WINAPI MakeThread(THREADED_FUNC &pTFunc, int nPassedValue);
// Starting and ending point of the dll, required for every api dll
extern "C" int APIENTRY DllMain(HINSTANCE hInstance, DWORD dwReason, LPVOID lpReserved)
{
if (dwReason == DLL_PROCESS_ATTACH)
{
// dll starts processing here
// inital values and processing should go here
}
else if (dwReason == DLL_PROCESS_DETACH)
{
// dll stops processing here
// all clean up code should go here
}
return 1;
}
// MakeThread - Function that calls function by address (This is the callback routine)
// This function accepts a THREADED_FUNC which is actually the address of the threaded function
// It also accepts the parameters your function takes which is an integer for this example. You will need to set the
// number of parameters to match the function you wrote
LONG __declspec(dllexport) WINAPI MakeThread(int nPassedValue, THREADED_FUNC &pTFunc)
{
// try-catch block for error handling
try
{
do
{
// call the function by address and examin return value
if (pTFunc(nPassedValue) == FALSE)
return 1;
FreeProcessor();
} while (true);
}
catch (int) { return 0; }
}
// FreeProcessor function written by Jared Bruni
void FreeProcessor(void)
{
MSG Msg;
while(PeekMessage(&Msg,NULL,0,0,PM_REMOVE))
{
if (Msg.message == WM_QUIT)break;
TranslateMessage(&Msg);
DispatchMessage(&Msg);
}
}
The next step is to create a export definitions file for MakeThread. This is very simple.
LIBRARY MyFile
DESCRIPTION 'Callback multithreading dll for MyProgram'
CODE PRELOAD MOVEABLE DISCARDABLE
DATA PRELOAD MOVEABLE SINGLEHEAPSIZE 4096
EXPORTS
MakeThread @1
I highlighted the LIBRARY line for a good reason. Make sure whatever you type after LIBRARY is the name of the cpp file that your DllMain is in. For example if your DllMain is in a file called "BigLousyDll.cpp", then you would type LIBRARY BigLousyDllAlso make sure that the export definitions file is the same name as the cpp file your DllMain is in. Like I said, if your DllMain is in a file called "BigLousyDll.cpp", you would name your export definitions file BigLousyDll.defOnce you compile your dll, it should automatically be registered. I would put it in your system or system32 folder so you don't have to type a explicit path to it in your vb file.Public Declare Function MakeThread Lib "MyFile.dll" (lpCallback As Any, ByVal nInt As Integer) As Long
Public i As Integer
Public nTimes As IntegerPublic Function MyFunction(ByVal nValue As Integer) As Boolean nTimes = nTimes + 1
If nTimes > 0 Then
If i < 20 Then
i = i + 1
End If
MyFunction = True 'Tells dll to keep running through function
Exit Function
Else
i = nValue
MyFunction = True 'Tells dll to keep running through function
Exit Function
End If
MyFunction = False 'Tells dll to stop
End Function
Sub Main() If Not MakeThread(AddressOf MyFunction, 3) Then
MsgBox "Multithreading error"
Else
MsgBox "Success"
End If
End Sub
If you find this code helpful, vote only if you want to. I dont care if I win coding contest. I just thought this solution is excellent compared to what Srideep Prasad posted.
Easy, Stable VB6 Multithreading with Low Overhead - Part 2
Calling CreateThread Safely Within a DLLI found some better, straight vb code for the tutorial I was going to do for this part so I thought it would be better than using c++. The code does the same thing.Part 2 of thesse tutorials is based off Matthew Curland's "Apartment Threading in VB6, Safely and Externally". This uses a precompiled type library to easily call CreateThread from a global name space (no declaration required). While this might be use activex, it still isn't using nearly as many system resources as Srideep's solution.In addition to safely calling CreateThread from vb there are some thread classes that are used for doing the work with class ids rather than function addresses. (Launch, Worker, ThreadControl, ThreadData, and ThreadLaunch)I will list all the classes below. I also decide4d not to add syntax highlighting because that took too long. Also please realize that I did not write these. Matthew Curland did. So vote for him, not me.ThreadControl.cls
Option Explicit
Private m_RunningThreads As Collection'Collection to hold ThreadData objects for each thread
Private m_fStoppingWorkers As Boolean'Currently tearing down, so don't start anything new
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 th
' read.
'CLSID can be obtained from a ProgID via
' CLSIDFromProgID
'Data contains the data for the new thre
' ad
'fStealData should be True if the data i
' s large. If this
' is set, then Data will be Empty on ret
' urn. If Data
' contains an object reference, then the
' object should
' be created on this thread.
'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, Data As Variant, Optional ByVal fStealData As Boolean = False, Optional ByVal fReturnThreadHandle As Boolean = False) As Long
Dim TPD As ThreadProcData
Dim IID_IUnknown As VBGUID
Dim ThreadID As Long
Dim ThreadHandle As Long
Dim pStream As IUnknown
Dim ThreadData As ThreadData
Dim fCleanUpOnFailure As Boolean
Dim hProcess As Long
Dim pUnk As IUnknown
If m_fStoppingWorkers Then Err.Raise 5, , "Can't create new worker while shutting down"
CleanCompletedThreads 'We need to clean up sometime, this is as good a time as any
With TPD
Set ThreadData = New ThreadData
.CLSID = CLSID
.EventHandle = m_EventHandle
With IID_IUnknown
.Data4(0) = &HC0
.Data4(7) = &H46
End With
.pMarshalStream = CoMarshalInterThreadInterfaceInStream(IID_IUnknown, Me)
.ThreadDonePointer = ThreadData.ThreadDonePointer
.ThreadDataCookie = ObjPtr(ThreadData)
.pCritSect = m_pCS
ThreadData.SetData Data, fStealData
Set ThreadData.Controller = Me
m_RunningThreads.Add ThreadData, CStr(.ThreadDataCookie)
End With
ThreadHandle = CreateThread(0, 0, AddressOf ThreadProc.ThreadStart, VarPtr(TPD), 0, ThreadID)
If ThreadHandle = 0 Then
fCleanUpOnFailure = True
Else
'Turn ownership of the thread handle ove
' r to
'the ThreadData object
ThreadData.ThreadHandle = ThreadHandle
'Make sure we've been notified by Thread
' Proc before continuing to
'guarantee that the new thread has gotte
' n 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
'Failure, clean up stream by making a re
' ference and releasing it
CopyMemory pStream, TPD.pMarshalStream, 4
Set pStream = Nothing
'Tell the thread its done using the norm
' al mechanism
InterlockedIncrement TPD.ThreadDonePointer
'There's no reason to keep the new threa
' d data
CleanCompletedThreads
End If
If TPD.hr Then Err.Raise TPD.hr
End Function
'Called after a thread is created to pro
' vide a mechanism
'to stop execution and retrieve initial
' data for running
'the thread. Should be called in ThreadL
' aunch_Go with:
'Controller.RegisterNewThread ThreadData
' Cookie, VarPtr(m_Notify), Controller, Da
' ta
Public Sub RegisterNewThread(ByVal ThreadDataCookie As Long, ByVal ThreadSignalPointer As Long, ByRef ThreadControl As ThreadControl, Optional Data As Variant)
Dim ThreadData As ThreadData
Dim fInCriticalSection As Boolean
Set ThreadData = m_RunningThreads(CStr(ThreadDataCookie))
ThreadData.ThreadSignalPointer = ThreadSignalPointer
ThreadData.GetData Data
'The new thread should not own the contr
' olling thread because
'the controlling thread has to teardown
' after all of the worker
'threads are done running code, which ca
' n't happen if we happen
'to release the last reference to Thread
' Control in a worker
'thread. ThreadData is already holding a
' n extra reference on
'this object, so it is guaranteed to rem
' ain alive until
'ThreadData is signalled.
Set ThreadControl = Nothing
If m_fStoppingWorkers Then
'This will only happen when StopWorkerTh
' reads is called
'almost immediately after CreateWorkerTh
' read. We could
'just let this signal happen in the Stop
' WorkerThreads loop,
'but this allows a worker thread to be s
' ignalled immediately.
'See note in SignalThread about Critical
' Section usage.
ThreadData.SignalThread m_pCS, fInCriticalSection
If fInCriticalSection Then LeaveCriticalSection m_pCS
End If
End Sub
'Call StopWorkerThreads to signal all wo
' rker threads
'and spin until they terminate. Any call
' s to an object
'passed via the Data parameter in Create
' WorkerThread
'will succeed.
Friend Sub StopWorkerThreads()
Dim ThreadData As ThreadData
Dim fInCriticalSection As Boolean
Dim fSignal As Boolean
Dim fHaveOleThreadhWnd As Boolean
Dim OleThreadhWnd As Long
If m_fStoppingWorkers Then Exit Sub
m_fStoppingWorkers = True
fSignal = True
Do
For Each ThreadData In m_RunningThreads
If ThreadData.ThreadCompleted Then
m_RunningThreads.Remove CStr(ObjPtr(ThreadData))
ElseIf fSignal Then
'See note in SignalThread about Critical
' Section usage.
ThreadData.SignalThread m_pCS, fInCriticalSection
End If
Next
If fInCriticalSection Then
LeaveCriticalSection m_pCS
fInCriticalSection = False
Else
'We can turn this off indefinitely becau
' se new threads
'which arrive at RegisterNewThread while
' stopping workers
'are signalled immediately
fSignal = False
End If
If m_RunningThreads.Count = 0 Then Exit Do
'We need to clear the message queue here
' in order to allow
'any pending RegisterNewThread messages
' to come through.
If Not fHaveOleThreadhWnd Then
OleThreadhWnd = FindOLEhWnd
fHaveOleThreadhWnd = True
End If
SpinOlehWnd OleThreadhWnd, False
Sleep 0
Loop
m_fStoppingWorkers = False
End Sub
'Releases ThreadData objects for all thr
' eads
'that are completed. Cleaning happens au
' tomatically
'when you call SignalWorkerThreads, Stop
' WorkerThreads,
'and RegisterNewThread.
Friend Sub CleanCompletedThreads()
Dim ThreadData As ThreadData
For Each ThreadData In m_RunningThreads
If ThreadData.ThreadCompleted Then
m_RunningThreads.Remove CStr(ObjPtr(ThreadData))
End If
Next
End Sub
'Call to tell all running worker threads
' to
'terminated. If the thread has not yet c
' alled
'RegisterNewThread, then it will not be
' signalled.
'Unlike StopWorkerThreads, this does not
' block
'while the workers actually terminate.
'SignalWorkerThreads must be called by t
' he owner
'of this class before the ThreadControl
' instance
'is released.
Friend Sub SignalWorkerThreads()
Dim ThreadData As ThreadData
Dim fInCriticalSection As Boolean
For Each ThreadData In m_RunningThreads
If ThreadData.ThreadCompleted Then
m_RunningThreads.Remove CStr(ObjPtr(ThreadData))
Else
'See note in SignalThread about Critical
' Section usage.
ThreadData.SignalThread m_pCS, fInCriticalSection
End If
Next
If fInCriticalSection Then LeaveCriticalSection m_pCS
End Sub
Private Sub Class_Initialize()
Set m_RunningThreads = New Collection
m_EventHandle = CreateEvent(0, 0, 0, vbNullString)
m_pCS = VarPtr(m_CS)
InitializeCriticalSection m_pCS
End Sub
Private Sub Class_Terminate()
CleanCompletedThreads'Just in case, this generally does nothing.
Debug.Assert m_RunningThreads.Count = 0 'Each worker should have a reference to this class
CloseHandle m_EventHandle
DeleteCriticalSection m_pCS
End Sub Launch.cls
Option Explicit
Private Controller As ThreadControl
Public Sub LaunchThreads()
Dim CLSID As CLSID
CLSID = CLSIDFromProgID("DllThreads.Worker")
Controller.CreateWorkerThread CLSID, 3000, True
Controller.CreateWorkerThread CLSID, 5000, True
Controller.CreateWorkerThread CLSID, 7000
End Sub
Public Sub FinishThreads()
Controller.StopWorkerThreads
End Sub
Public Sub CleanCompletedThreads()
Controller.CleanCompletedThreads
End Sub
Private Sub Class_Initialize()
Set Controller = New ThreadControl
End Sub
Private Sub Class_Terminate()
Controller.StopWorkerThreads
Set Controller = Nothing
End Sub
ThreadLaunch.cls
Option Explicit
'Just an interface definition
Public Function Go(Controller As ThreadControl, ByVal ThreadDataCookie As Long) As Long
End Function
'The rest of this is a comment
#If False Then
'A worker thread should include the foll
' owing code.
'The Instancing for a worker should be s
' et to 5 - MultiUse
Implements ThreadLaunch
Private m_Notify As Long
Public Function ThreadLaunch_Go(Controller As ThreadControl, ByVal ThreadDataCookie As Long) As Long
Dim Data As Variant
Controller.RegisterNewThread ThreadDataCookie, VarPtr(m_Notify), Controller, Data
'TODO: Process Data while
'regularly calling HaveBeenNotified to
'see if the thread should terminate.
If HaveBeenNotified Then
'Clean up and return
End If
End Function
Private Function HaveBeenNotified() As Boolean
HaveBeenNotified = m_Notify
End Function
#End If
Worker.cls
Option Explicit
Implements ThreadLaunch
Private m_Notify As Long
Public Function ThreadLaunch_Go(Controller As ThreadControl, ByVal ThreadDataCookie As Long) As Long
Dim Data As Variant
Dim SleepTime As Long
Controller.RegisterNewThread ThreadDataCookie, VarPtr(m_Notify), Controller, Data
ThreadLaunch_Go = Data
SleepTime = Data
While SleepTime > 0
Sleep 100
SleepTime = SleepTime - 100
If HaveBeenNotified Then
MsgBox "Notified"
Exit Function
End If
Wend
MsgBox "Done Sleeping: " & Data
End Function
Private Function HaveBeenNotified() As Boolean
HaveBeenNotified = m_Notify
End Function
ThreadData.cls
Option Explicit
Private m_ThreadDone As Long
Private m_ThreadSignal As Long
Private m_ThreadHandle As Long
Private m_Data As Variant
Private m_Controller As ThreadControl
Friend Function ThreadCompleted() As Boolean
Dim ExitCode As Long
ThreadCompleted = m_ThreadDone
If ThreadCompleted Then
'Since code runs on the worker thread af
' ter the
'ThreadDone pointer is incremented, ther
' e is a chance
'that we are signalled, but the thread h
' asn't yet
'terminated. In this case, just claim we
' aren't done
'yet to make sure that code on all worke
' r threads is
'actually completed before ThreadControl
' terminates.
If m_ThreadHandle Then
If GetExitCodeThread(m_ThreadHandle, ExitCode) Then
If ExitCode = STILL_ACTIVE Then
ThreadCompleted = False
Exit Function
End If
End If
CloseHandle m_ThreadHandle
m_ThreadHandle = 0
End If
End If
End Function
Friend Property Get ThreadDonePointer() As Long
ThreadDonePointer = VarPtr(m_ThreadDone)
End Property
Friend Property Let ThreadSignalPointer(ByVal RHS As Long)
m_ThreadSignal = RHS
End Property
Friend Property Let ThreadHandle(ByVal RHS As Long)
'This takes over ownership of the Thread
' Handle
m_ThreadHandle = RHS
End Property
Friend Sub SignalThread(ByVal pCritSect As Long, ByRef fInCriticalSection As Boolean)
'm_ThreadDone and m_ThreadSignal must be
' checked/modified inside
'a critical section because m_ThreadDone
' could change on some
'threads while we are signalling, causin
' g m_ThreadSignal to point
'to invalid memory, as well as other pro
' blems. The parameters to this
'function are provided to ensure that th
' e critical section is entered
'only when necessary. If fInCriticalSect
' ion is set, then the caller
'must call LeaveCriticalSection on pCrit
' Sect. This is left up to the
'caller since this function is designed
' to be called on multiple instances
'in a tight loop. There is no point in r
' epeatedly entering/leaving the
'critical section.
If m_ThreadSignal Then
If Not fInCriticalSection Then
EnterCriticalSection pCritSect
fInCriticalSection = True
End If
If m_ThreadDone = 0 Then
InterlockedIncrement m_ThreadSignal
End If
'No point in signalling twice
m_ThreadSignal = 0
End If
End Sub
Friend Property Set Controller(ByVal RHS As ThreadControl)
Set m_Controller = RHS
End Property
Friend Sub SetData(Data As Variant, ByVal fStealData As Boolean)
If IsEmpty(Data) Or IsMissing(Data) Then Exit Sub
If fStealData Then
CopyMemory ByVal VarPtr(m_Data), ByVal VarPtr(Data), 16
CopyMemory ByVal VarPtr(Data), 0, 2
ElseIf IsObject(Data) Then
Set m_Data = Data
Else
m_Data = Data
End If
End Sub
Friend Sub GetData(Data As Variant)
'This is called only once. Always steal.
'
'Before stealing, make sure there's
'nothing lurking in Data
Data = Empty
CopyMemory ByVal VarPtr(Data), ByVal VarPtr(m_Data), 16
CopyMemory ByVal VarPtr(m_Data), 0, 2
End Sub
Private Sub Class_Terminate()
'This shouldn't happen, but just in case
'
If m_ThreadHandle Then CloseHandle m_ThreadHandle
End Sub