'功能：創建多線程類，用於初始化線程。 類名：cls_Thread
'參數：LongPointFunction 用於接收主調過程傳遞過來的函數地址值
'調用方法：1.聲明線程類對象變量 Dim mythread as cls_Thread
' 2.調用形式：With mythread
' .Initialize AddressOf 自定義過程或函數名 '(初始化線程) .
' .ThreadEnabled = True '(設置線程是否激活)
' End With
' 3.終止調用： Set mythread = Nothing
' Email:[email protected]
' Test On： VB6.0+Win2000 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