下面代码在cls里面(class)
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
Dim LongCreationFlags As Long
Dim LpthreadId As Long
Dim 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 = True 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
下面代码在模块里面
Option Explicit
'声明Class1类的对象变量
Public MyProBar As New Class1
Dim Vals As Integer
Sub Main()
Load Form1
Form1.Show
End Sub
Public Sub ProBar()
For Vals = 1 To 500
Form1.ProgressBar1.Value = Form1.ProgressBar1.Value + 1
DoEvents
Next Vals
Set MyProBar = Nothing
End Sub
form1里面的代码
Private Sub Form_Load()
Me.ProgressBar1.Max = 500
Me.ProgressBar1.Min = 0
Me.ProgressBar1.Value = 0
End Sub
Private Sub Command1_Click()
With MyProBar
.Initialize AddressOf ProBar
.ThreadEnabled = True
End With
L = MsgBox("多线程演示", 48, "警告")
If L = 1 Then Unload Me
end sub
要看到更好的效果,就把max再设大些5000,启动窗体是submain