VB創建多線程應用程序(二)

源代碼如下：

窗體中的代碼：

Option Explicit

 

´開始

Private Sub Command1_Click()

  

   On Error Resume Next

  

   With myThreadleft

        .Initialize AddressOf Fillleft            ´傳遞過程地址給線程

        .ThreadEnabled = True

   End With

   With myThreadright

        .Initialize AddressOf Fillright

        .ThreadEnabled = True

   End With

   With myThreadbottom

        .Initialize AddressOf Fillbottom

        .ThreadEnabled = True

   End With

  

   MsgBox "多線程正在運行...，看看圖片框控件的變色效果！", 64, "信息"

  

   ´終止線程運行

   Set myThreadleft = Nothing

   Set myThreadright = Nothing

   Set myThreadbottom = Nothing

  

End Sub

 

´結束

Private Sub Command2_Click()

   Unload Me

End Sub

模塊中的代碼：

Option Explicit

 

´時間計數API

Private Declare Function GetTickCount Lib "kernel32" () As Long

 

´聲明cls_thread類的對象變量

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             ´延時10毫秒,下同

           Wend

       Next

       Set myThreadleft = Nothing  ´如果循環結束則終止當前線程運行，下同

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 Sub

 

Public 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

類模塊中的代碼：

 

´功能：創建多線程類，用于初始化線程。   類名：cls_Thread 

´參數：LongPointFunction 用于接收主調過程傳遞過來的函數地址值

´調用方法：1.聲明線程類對象變量 Dim mythread as cls_Thread

´          2.調用形式：With mythread

´                         .Initialize AddressOf 自定義過程或函數名 ´(初始化線程) .

´                         .ThreadEnabled = True                  ´(設置線程是否激活)

´                      End With                                       

´          3.終止調用： Set mythread = Nothing                                                                           

´   Crate By : 陳宇 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

´創建線程API

´此API經過改造，lpThreadAttributes改為Any型，lpStartAddress改為傳值引用：

´因為函數的入口地址由形參變量傳遞，如果用傳址那將傳遞形參變量的地址而不是函數的入口地址

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

´終止線程API

Private Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long

´激活線程API

Private Declare Function ResumeThread Lib "kernel32" (ByVal hThread As Long) As Long

´掛起線程API

Private Declare Function SuspendThread Lib "kernel32" (ByVal hThread As Long) As Long

 

Private Const CREATE_SUSPENDED = &H4    ´線程掛起常量

 

´自定義線程結構類型

Private Type udtThread

        Handle As Long

        Enabled As Boolean

End Type

 

Private meTheard As udtThread

´初始化線程

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         ´創建線程后先掛起，由程序激活線程

      

       ´創建線程并返線程句柄

       meTheard.Handle = CreateThread(LongNull, LongStackSize, ByVal LongPointFunction, LongNull, LongCreationFlags, LpthreadId)

      

       If meTheard.Handle = LongNull Then

          MsgBox "線程創建失??！", 48, "錯誤"

       End If

End Sub

 

´獲取線程是否激活屬性

Public Property Get ThreadEnabled() As Boolean

       On Error Resume Next

       Enabled = meTheard.Enabled

End Property

 

´設置線程是否激活屬性

Public Property Let ThreadEnabled(ByVal Newvalue As Boolean)

       On Error Resume Next

       ´若激活線程（Newvalue為真）設為TRUE且此線程原來沒有激活時激活此線程

       If Newvalue And (Not meTheard.Enabled) Then

          ResumeThread meTheard.Handle

          meTheard.Enabled = True

       Else          ´若激活線程（Newvalue為真）且此線程原來已激活則掛起此線程

          If meTheard.Enabled Then

             SuspendThread meTheard.Handle

             meTheard.Enabled = False

          End If

       End If

End Property

 

´終止線程事件

Private Sub Class_Terminate()

        On Error Resume Next

        Call TerminateThread(meTheard.Handle, 0)

End Sub

總結：

本程序的缺點是程序運行時CPU占用率高。

至此全部源代碼結束，在實例的基礎上可以根據個人需要做出不同的多線程應用程序，可以用此類模塊創建ActiveX DLL，然后引用這個DLL來進行調用。希望對大家有用，若大家找到一種更好的實現方法且CPU占用率低的程序請通知我，程序中有什么Bug請Email，謝謝。

原文轉自：http://www.anti-gravitydesign.com