The source code is as follows:
Code in the form: Option Explicit
'Start Private Sub Command1_Click () On Error Resume Next With myThreadleft .Initialize AddressOf Fillleft' address to the delivery process thread .ThreadEnabled = True End With With myThreadright .Initialize AddressOf Fillright .ThreadEnabled = True End With With myThreadbottom .Initialize AddressOf Fillbottom .ThreadEnabled = True end with msgbox "Multithreading is running ..., look at the color change effect of the picture box control!", 64, "Information" termination thread run set mythreadright = Nothing set mythreadright = Nothing set mythreadbottom = Nothing End Sub
'End Private submmand2_click () Unload me End Sub module code: Option Explicit
'Time count API private declare function gettickcount lib "kernel32" () AS Long
'Declaring CLS_THREAD Class Object Variable PUBLIC MythreadLeft AS New CLS_THREAD, Mythreadright As New CLS_THREAD, MythreadBottom As New CLS_THREAD
Sub main () load form1 form1.show end sub
Public Sub Fillleft () Static Bkgcolor As Long Dim LongTick As Long, Longcounter As Long On Error Resume Next For Longcounter = 0 To 3000 DoEvents Bkgcolor = Longcounter Mod 256 Form1.Picture1.BackColor = RGB (Bkgcolor, 0, 0) LongTick = GetTickCount While gettickcount - longTick <10 'delay 10 milliseconds, the following wend next set mythreadleft = Nothing' If the cycle ends, termination of the current thread run, the following End Sub
Public Sub Fillright () Static Bkgcolor As Long Dim LongTickValue As Long, Longcounter As Long On Error Resume Next For Longcounter = 0 To 3000 DoEvents Bkgcolor = Longcounter Mod 256 Form1.Picture2.BackColor = RGB (0, Bkgcolor, 0) LongTickValue = GetTickCount While GetTickCount - LongTickValue <10 Wend Next Set myThreadright = Nothing End SubPublic Sub Fillbottom () Static Bkgcolor As Long Dim LongTick As Long, Longcounter As Long On Error Resume Next For Longcounter = 0 To 3000 DoEvents Bkgcolor = Longcounter Mod 256 Form1.Picture3. Backcolor = RGB (0, 0, bkgcolor) longTick = gettickcount while gettickcount - longTick <10 Wend next set mythreadright = Nothing End Sub class module code:
'Features: Create a multi-thread class for initialization threads. Class Name: CLS_THREAD 'Parameters: longpointFunction For receiving the function address value' calling method for receiving the main adjustment process: 1. Declaration thread class object variable DIM mythread as cls_thread '2. Call form: with mythread' .initialize addressof Custom Process Or function name '(initial thread).' .Threadenabled = true '(setting thread is activated)' end with '3. Termination call: set mythread = Nothing' crate By: Chen Yu On 2004.5.10 CopyRight (c) .ldt BY CY-Soft 2001--2004 'Email: 4Y4YCOCO@163.com' Test On: VB6.0 Win98 and VB6.0 WinXP It's Pass! Option Explicit 'Creating Thread API' This API is transformed, and LPTHREADAttribute is changed to an iY type. LPStartAddress is changed to the piped reference: 'Because the function's entry address is passed by a den, if the address of the parameter is transferred to the address entry address is not a function of the Private Declare function CreateThread Lib "kernel32" (ByVal lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpthreadId As Long) As Long 'to terminate the thread API Private Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long 'active threads API Private Declare Function ResumeThread Lib "kernel32" (ByVal hThread As Long) As Long' hung thread API Private Declare Function SuspendThread Lib " Kernel32 (Byval HThread As Long) As Long
Private const create_suspended = & h4 'thread hang constant
'Custom thread structure type Private Type udtThread Handle As Long Enabled As Boolean End TypePrivate meTheard As udtThread' initializing thread Public Sub Initialize (ByVal LongPointFunction As Long) Dim LongStackSize As Long, LongCreationFlags As Long, LpthreadId As Long, LongNull As Long On Error Resume Next LongNull = 0 LongStackSize = 0 LongCreationFlags = CREATE_SUSPENDED 'created after the first thread suspended by a program active thread' create a thread and returns a handle to the thread meTheard.Handle = CreateThread (LongNull, LongStackSize, ByVal LongPointFunction, LongNull, LongCreationFlags, lpthreadId) If Metheard.Handle = longnull the msgbox "Thread Creation Failed!", 48, "Error" end if End Sub
'Get Thread Whether Activates Properties Public Property Get ThreadEnabled () AS Boolean On Error ResMe Next Enabled = Metheard.Enabled End Property
'Set whether the thread is activated attribute Public property let threadenabled (Byval newValue as boolean) ON Error Resume Next' If the thread is activated, this thread is activated when this thread is not activated, and the thread if NEWVALUE AND (Not Metheard.enable) ) then ResumeThread meTheard.Handle meTheard.Enabled = true Else 'If the active thread (Newvalue is true) and this thread originally activated the suspended this thread If meTheard.Enabled then SuspendThread meTheard.Handle meTheard.Enabled = False End If End If End Property
'Termination Thread Event Private Sub Class_Terminate () ON Error ResMe Next Call TerminateThread (Metheard.handle, 0) End Sub Summary:
