This project is a standalone ActiveX EXE application that shows how to create multiple threads to perform lengthy tasks and then communicate the results via "event-like" callbacks. In this example, we are using 5 threads and each thread is checking whether a rather large number is prime or not. The project is set up so you can easily add more tasks for each thread to perform. All threads are placed in an array so we can easily communicate with each of them via their index in the array:
![Name: VB_MultiThreading.png
Views: 40
Size: 12.7 KB]()
The project is IDE-safe, you can break or stop at any time without crashes, however the IDE runs single-threaded so you will see the same "Thread ID" across the board and you cannot check more than one number at a time. When compiled into an executable, each thread will be different as seen in the above screenshot and you can check more numbers at the same time without any problems.
Be careful when checking very large numbers. If they are composite then the result will be shown very fast but if you hit a large prime (larger than what you see in the screenshot) then the algorithm will take a VERY long time to finish. Suggestions for improvement are welcome in this area! :D
frmVBMultiThreading - The main form containing the user interface.
clsVBMultiThreading - Set to "MultiUse", each instance of this class will be created in a separate Thread!
IVBThread - simple interface class to declare callback "events" raised by each thread in the array of threads:
mdlVBMultiThreading - module containing our "IsPrime" function that does all the work in each thread
frmThread - Hidden form loaded in each thread only for the purpose of starting thread jobs "asynchronously".
Here is the Demo Project: VB_MultiThreading.zip. That's all there is to Multithreading in VB6! :)
The project is IDE-safe, you can break or stop at any time without crashes, however the IDE runs single-threaded so you will see the same "Thread ID" across the board and you cannot check more than one number at a time. When compiled into an executable, each thread will be different as seen in the above screenshot and you can check more numbers at the same time without any problems.
Be careful when checking very large numbers. If they are composite then the result will be shown very fast but if you hit a large prime (larger than what you see in the screenshot) then the algorithm will take a VERY long time to finish. Suggestions for improvement are welcome in this area! :D
frmVBMultiThreading - The main form containing the user interface.
Code:
Option Explicit
Implements IVBThread
Private Const THREADS_COUNT As Long = 5
Private Const SND_ASYNC As Long = &H1, SND_MEMORY As Long = &H4
Private Declare Function sndPlaySound Lib "winmm" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long
Private Threads() As clsVBMultiThreading, byteJobsDone() As Byte, sProjectName As String
Private Sub cmdCheckPrime_Click(Index As Integer)
lblFactors(Index) = vbNullString: lblFactors(Index).Refresh
Threads(Index).StartAsyncTask eTaskCheckPrime, CDec(txtPrime(Index))
End Sub
Private Sub txtPrime_KeyPress(Index As Integer, KeyAscii As Integer)
If (KeyAscii < vbKey0 Or KeyAscii > vbKey9) And (KeyAscii <> vbKeyReturn) And (KeyAscii <> vbKeyBack) Then KeyAscii = 0
If KeyAscii = vbKeyReturn Then KeyAscii = 0: Call cmdCheckPrime_Click(Index)
End Sub
Private Sub Form_Activate()
Dim i As Long
Static bActivate As Boolean
If bActivate Then Exit Sub Else bActivate = True
For i = LBound(Threads) To UBound(Threads)
Set Threads(i) = CreateObject(sProjectName & ".clsVBMultiThreading")
Set Threads(i).Callback(i) = Me
lblThreadID(i) = Threads(i).ThreadID
Next i
End Sub
Private Sub Form_Load()
sProjectName = GetProjectName: ReadFile "JobsDone.wav", byteJobsDone
ReDim Threads(0 To THREADS_COUNT - 1)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim i As Long
For i = LBound(Threads) To UBound(Threads)
Set Threads(i) = Nothing
Next i
End Sub
Private Sub IVBThread_JobDone(ByVal Index As Long, Optional ByVal vParam As Variant, Optional vReturnValue As Variant)
If Not IsEmpty(vParam) Then
lblFactors(Index) = ArrayToString(vParam)
If vReturnValue Then lblFactors(Index) = lblFactors(Index) & " is Prime!"
End If
sndPlaySound byteJobsDone(0), SND_MEMORY Or SND_ASYNC
End SubCode:
Option Explicit
Public Enum eTasks
eTaskUndefined = 0
eTaskCheckPrime = 1
'Other tasks to be defined here
End Enum
Private Const WM_MOUSEMOVE As Long = &H200
Private Declare Function PostMessageVal Lib "user32" Alias "PostMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private WithEvents objThread As Form, m_Callback As IVBThread, m_Index As Long, m_CurrentTask As eTasks, m_ThreadID As Long, m_Params As Variant
Public Property Get Callback(Optional Index As Long) As IVBThread
Index = m_Index: Set Callback = m_Callback
End Property
Public Property Set Callback(Index As Long, objCallback As IVBThread)
m_Index = Index: Set m_Callback = objCallback
End Property
Public Sub StartAsyncTask(eTask As eTasks, ParamArray ParamsArray() As Variant)
Dim i As Long
m_Params = Empty
For i = LBound(ParamsArray) To UBound(ParamsArray)
If i = LBound(ParamsArray) Then ReDim m_Params(LBound(ParamsArray) To UBound(ParamsArray))
m_Params(i) = ParamsArray(i)
Next i
m_CurrentTask = eTask
PostMessageVal objThread.hWnd, WM_MOUSEMOVE, 0&, 0& ' Start the task asynchronously
End Sub
Public Property Get ThreadID() As Long
ThreadID = m_ThreadID
End Property
Private Sub JobDone(Optional ByVal vParam As Variant, Optional vReturnValue As Variant)
If Not (m_Callback Is Nothing) Then m_Callback.JobDone m_Index, vParam, vReturnValue
End Sub
Private Sub Class_Initialize()
Set objThread = New frmThread
Load objThread: m_ThreadID = App.ThreadID
End Sub
Private Sub Class_Terminate()
If objThread.IsLoaded Then Unload objThread ' Check if a form is already loaded without accidentally loading it
Set objThread = Nothing
End Sub
Private Sub objThread_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Select Case m_CurrentTask
Case eTaskCheckPrime
If Not IsEmpty(m_Params) Then
Dim vFactors As Variant, bIsPrime As Boolean
bIsPrime = IsPrime(m_Params(0), vFactors)
JobDone vFactors, bIsPrime
End If
End Select
End SubCode:
Option Explicit
Public Sub JobDone(ByVal Index As Long, Optional ByVal vParam As Variant, Optional vReturnValue As Variant)
End SubCode:
Option Explicit
Public Sub Main()
If Not App.TaskVisible Then Exit Sub ' Additional threads are re-entrant, meaning they will always execute the "Sub Main" so just exit the sub
frmVBMultiThreading.Show
End Sub
Public Function ArraySort(vArray As Variant) As Variant
Dim i As Long, bSwitch As Boolean, vTemp As Variant
Do
bSwitch = False
For i = LBound(vArray) To UBound(vArray) - 1
If vArray(i) > vArray(i + 1) Then
vTemp = vArray(i): vArray(i) = vArray(i + 1): vArray(i + 1) = vTemp: bSwitch = True
End If
Next i
Loop While bSwitch
ArraySort = vArray
End Function
Public Function ArrayToString(vArray As Variant, Optional sDelimiter As String = " ") As String
Dim i As Long
For i = LBound(vArray) To UBound(vArray)
ArrayToString = ArrayToString & vArray(i)
If i < UBound(vArray) Then ArrayToString = ArrayToString & sDelimiter
Next i
End Function
Public Function BigMod(vDividend As Variant, vDivisor As Variant) As Variant
BigMod = vDividend - Int(vDividend / vDivisor) * vDivisor
End Function
Public Function GetProjectName() As String
On Error Resume Next
Err.Raise 5: GetProjectName = Err.Source: Err.Clear
End Function
Public Function IsPrime(ByVal n As Variant, Optional arrFactors As Variant, Optional bNoRepeats As Boolean = True) As Boolean
Dim vFactors As Variant, i As Variant, j As Long, lCount As Long, factorCount As Long
ReDim vFactors(0 To 31)
If n <= 1 Then Exit Function
While BigMod(n, 2) = 0
n = n / 2: vFactors(factorCount) = 2: factorCount = factorCount + 1
If factorCount > UBound(vFactors) Then ReDim Preserve vFactors(0 To factorCount)
Wend
While BigMod(n, 3) = 0
n = n / 3: vFactors(factorCount) = 3: factorCount = factorCount + 1
If factorCount > UBound(vFactors) Then ReDim Preserve vFactors(0 To factorCount)
Wend
While BigMod(n, 5) = 0
n = n / 5: vFactors(factorCount) = 5: factorCount = factorCount + 1
If factorCount > UBound(vFactors) Then ReDim Preserve vFactors(0 To factorCount)
Wend
i = CDec(7)
While i <= n / i
If BigMod(n, i) = 0 Then
n = n / i: vFactors(factorCount) = i: factorCount = factorCount + 1
ElseIf BigMod(n, (i + 4)) = 0 Then
n = n / (i + 4): vFactors(factorCount) = i + 4: factorCount = factorCount + 1
ElseIf BigMod(n, (i + 6)) = 0 Then
n = n / (i + 6): vFactors(factorCount) = i + 6: factorCount = factorCount + 1
ElseIf BigMod(n, (i + 10)) = 0 Then
n = n / (i + 10): vFactors(factorCount) = i + 10: factorCount = factorCount + 1
ElseIf BigMod(n, (i + 12)) = 0 Then
n = n / (i + 12): vFactors(factorCount) = i + 12: factorCount = factorCount + 1
ElseIf BigMod(n, (i + 16)) = 0 Then
n = n / (i + 16): vFactors(factorCount) = i + 16: factorCount = factorCount + 1
ElseIf BigMod(n, (i + 22)) = 0 Then
n = n / (i + 22): vFactors(factorCount) = i + 22: factorCount = factorCount + 1
ElseIf BigMod(n, (i + 24)) = 0 Then
n = n / (i + 24): vFactors(factorCount) = i + 24: factorCount = factorCount + 1
Else
i = i + 30
End If
If factorCount > UBound(vFactors) Then ReDim Preserve vFactors(0 To factorCount)
Wend
If n > 1 Then vFactors(factorCount) = n: factorCount = factorCount + 1
If Not IsMissing(arrFactors) Then
n = 0
If bNoRepeats Then
For i = 0 To factorCount - 1
If vFactors(i) > 0 Then
lCount = 1
For j = i + 1 To factorCount - 1
If vFactors(j) = vFactors(i) Then
lCount = lCount + 1: vFactors(j) = 0
End If
Next j
vFactors(n) = vFactors(i) ^ lCount: n = n + 1
End If
Next i
ReDim Preserve vFactors(0 To n - 1): arrFactors = ArraySort(vFactors)
Else
ReDim Preserve vFactors(0 To factorCount - 1): arrFactors = vFactors
End If
End If
IsPrime = factorCount = 1
End Function
Public Sub ReadFile(sFileName As String, vData As Variant, Optional sCodePage As String = "_autodetect_all")
Dim oStream As Object
Set oStream = CreateObject("ADODB.Stream")
With oStream
Select Case VarType(vData)
Case vbArray Or vbByte
.Type = 1: .Open: .LoadFromFile sFileName: vData = .Read
Case vbString
.Charset = sCodePage: .Type = 2: .Open: .LoadFromFile sFileName: vData = .ReadText
End Select
If .state <> 0 Then .Close
End With
End SubCode:
Option Explicit
Private m_bIsLoaded As Boolean
Public Property Get IsLoaded() As Boolean
IsLoaded = m_bIsLoaded
End Property
Private Sub Form_Load()
m_bIsLoaded = True
Caption = Caption & App.ThreadID
End Sub