在csdn上的例程确实太老了,而且实用性不大。 下面给出完全用vb实现的多线程程序。 ----------以下在Main.bas中定义------------------ '这里的例子函数是开线程后的函数入口 '这里您可以定义自己的程序 Private Declare Function GetTickCount Lib "kernel32" () As Long Public Sub FlickerTop()Static BgColor As Long Dim lTick As Long, lCounter As LongOn Error Resume Next For lCounter = 0 To 5999 If BgColor <> &HFF& Then BgColor = &HFF& Else BgColor = &HFF00& Form1.Picture1.BackColor = BgColor lTick = GetTickCount While GetTickCount - lTick < 1250 Wend NextEnd Sub -------------------在cls中的定义------------------------ Private Type udtThread Handle As Long Enabled As Boolean End TypePrivate uThread As udtThreadPrivate Const CREATE_SUSPENDED As Long = &H4 Private Const THREAD_BASE_PRIORITY_IDLE As Long = -15 Private Const THREAD_BASE_PRIORITY_LOWRT As Long = 15 Private Const THREAD_BASE_PRIORITY_MAX As Long = 2 Private Const THREAD_BASE_PRIORITY_MIN As Long = -2 Private Const THREAD_PRIORITY_HIGHEST As Long = THREAD_BASE_PRIORITY_MAX Private Const THREAD_PRIORITY_LOWEST As Long = THREAD_BASE_PRIORITY_MIN Private Const THREAD_PRIORITY_ABOVE_NORMAL As Long = (THREAD_PRIORITY_HIGHEST - 1) Private Const THREAD_PRIORITY_BELOW_NORMAL As Long = (THREAD_PRIORITY_LOWEST + 1) Private Const THREAD_PRIORITY_IDLE As Long = THREAD_BASE_PRIORITY_IDLE Private Const THREAD_PRIORITY_NORMAL As Long = 0 Private Const THREAD_PRIORITY_TIME_CRITICAL As Long = THREAD_BASE_PRIORITY_LOWRTPrivate 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 Private Declare Function ResumeThread Lib "kernel32" (ByVal hThread As Long) As Long Private Declare Function SetThreadPriority Lib "kernel32" (ByVal hThread As Long, ByVal nPriority As Long) As Long Private Declare Function GetThreadPriority Lib "kernel32" (ByVal hThread As Long) As Long Private Declare Function SuspendThread Lib "kernel32" (ByVal hThread As Long) As Long Private Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long Public Sub Initialize(ByVal lpfnBasFunc As Long)Dim lStackSize As Long, lCreationFlags As Long, lpThreadId As Long, lNull As Long
On Error Resume Next lNull = 0 lStackSize = 0 lCreationFlags = CREATE_SUSPENDED uThread.Handle = CreateThread(lNull, lStackSize, lpfnBasFunc, lNull, lCreationFlags, lpThreadId) If uThread.Handle = lNull Then MsgBox "Create thread failed!"
End Sub Public Property Get Enabled() As Boolean
On Error Resume Next Enabled = uThread.EnabledEnd Property Public Property Let Enabled(ByVal vNewValue As Boolean)
On Error Resume Next If vNewValue And (Not uThread.Enabled) Then ResumeThread uThread.Handle uThread.Enabled = True ElseIf uThread.Enabled Then SuspendThread uThread.Handle uThread.Enabled = False End IfEnd Property Public Property Get Priority() As LongOn Error Resume Next Priority = GetThreadPriority(uThread.Handle)End Property Public Property Let Priority(ByVal vNewValue As Long)On Error Resume Next If vNewValue = -2 Then Call SetThreadPriority(uThread.Handle, THREAD_PRIORITY_LOWEST) ElseIf vNewValue = -1 Then Call SetThreadPriority(uThread.Handle, THREAD_PRIORITY_BELOW_NORMAL) ElseIf vNewValue = 0 Then Call SetThreadPriority(uThread.Handle, THREAD_PRIORITY_NORMAL) ElseIf vNewValue = 1 Then Call SetThreadPriority(uThread.Handle, THREAD_PRIORITY_ABOVE_NORMAL) ElseIf vNewValue = 2 Then Call SetThreadPriority(uThread.Handle, THREAD_PRIORITY_HIGHEST) End IfEnd Property Private Sub Class_Terminate()On Error Resume Next Call TerminateThread(uThread.Handle, 0)End Sub ---------------------在主程序中--------------------- Dim myThreadTop As New clsThreads, myThreadBottom As New clsThreadsOn Error Resume Next With myThreadTop .Initialize AddressOf FlickerTop .Enabled = True End With '处理其他程序 ...'注意使用后释放资源 Set myThreadTop = Nothing Set myThreadBottom = Nothing
you can Create new one Object to create a Thread.
发email:[email protected] 给我,谢谢
那个工程
vbthread.zip 在VB应用程序中使用多线程的例子 14K
vbthread.zip 在VB应用程序中使用多线程的例子 14K
这个例子是作了一个.dll但是我总不能用别人开发出来的东西吧,再说这个例子我看了
运行时会出现开发的信息,必须注册和著者联系,否则的话,那条信息总是显示出来,烦的很
目前我已能用 createthread()函数创建一个线程,但当我增加一个线程时,程序能够运行.
但退出时,程序出错,连vb也退了出来,我检查过了,我按退出按钮时,两个线程均已exit func , 我不明白这是怎么回事,难道是因为,标准exe工程只允许单线程的缘故? 原作者
下面给出完全用vb实现的多线程程序。
----------以下在Main.bas中定义------------------
'这里的例子函数是开线程后的函数入口
'这里您可以定义自己的程序
Private Declare Function GetTickCount Lib "kernel32" () As Long
Public Sub FlickerTop()Static BgColor As Long
Dim lTick As Long, lCounter As LongOn Error Resume Next
For lCounter = 0 To 5999
If BgColor <> &HFF& Then BgColor = &HFF& Else BgColor = &HFF00&
Form1.Picture1.BackColor = BgColor
lTick = GetTickCount
While GetTickCount - lTick < 1250
Wend
NextEnd Sub
-------------------在cls中的定义------------------------
Private Type udtThread
Handle As Long
Enabled As Boolean
End TypePrivate uThread As udtThreadPrivate Const CREATE_SUSPENDED As Long = &H4
Private Const THREAD_BASE_PRIORITY_IDLE As Long = -15
Private Const THREAD_BASE_PRIORITY_LOWRT As Long = 15
Private Const THREAD_BASE_PRIORITY_MAX As Long = 2
Private Const THREAD_BASE_PRIORITY_MIN As Long = -2
Private Const THREAD_PRIORITY_HIGHEST As Long = THREAD_BASE_PRIORITY_MAX
Private Const THREAD_PRIORITY_LOWEST As Long = THREAD_BASE_PRIORITY_MIN
Private Const THREAD_PRIORITY_ABOVE_NORMAL As Long = (THREAD_PRIORITY_HIGHEST - 1)
Private Const THREAD_PRIORITY_BELOW_NORMAL As Long = (THREAD_PRIORITY_LOWEST + 1)
Private Const THREAD_PRIORITY_IDLE As Long = THREAD_BASE_PRIORITY_IDLE
Private Const THREAD_PRIORITY_NORMAL As Long = 0
Private Const THREAD_PRIORITY_TIME_CRITICAL As Long = THREAD_BASE_PRIORITY_LOWRTPrivate 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
Private Declare Function ResumeThread Lib "kernel32" (ByVal hThread As Long) As Long
Private Declare Function SetThreadPriority Lib "kernel32" (ByVal hThread As Long, ByVal nPriority As Long) As Long
Private Declare Function GetThreadPriority Lib "kernel32" (ByVal hThread As Long) As Long
Private Declare Function SuspendThread Lib "kernel32" (ByVal hThread As Long) As Long
Private Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Public Sub Initialize(ByVal lpfnBasFunc As Long)Dim lStackSize As Long, lCreationFlags As Long, lpThreadId As Long, lNull As Long
On Error Resume Next
lNull = 0
lStackSize = 0
lCreationFlags = CREATE_SUSPENDED
uThread.Handle = CreateThread(lNull, lStackSize, lpfnBasFunc, lNull, lCreationFlags, lpThreadId)
If uThread.Handle = lNull Then MsgBox "Create thread failed!"
End Sub
Public Property Get Enabled() As Boolean
On Error Resume Next
Enabled = uThread.EnabledEnd Property
Public Property Let Enabled(ByVal vNewValue As Boolean)
On Error Resume Next
If vNewValue And (Not uThread.Enabled) Then
ResumeThread uThread.Handle
uThread.Enabled = True
ElseIf uThread.Enabled Then
SuspendThread uThread.Handle
uThread.Enabled = False
End IfEnd Property
Public Property Get Priority() As LongOn Error Resume Next
Priority = GetThreadPriority(uThread.Handle)End Property
Public Property Let Priority(ByVal vNewValue As Long)On Error Resume Next
If vNewValue = -2 Then
Call SetThreadPriority(uThread.Handle, THREAD_PRIORITY_LOWEST)
ElseIf vNewValue = -1 Then
Call SetThreadPriority(uThread.Handle, THREAD_PRIORITY_BELOW_NORMAL)
ElseIf vNewValue = 0 Then
Call SetThreadPriority(uThread.Handle, THREAD_PRIORITY_NORMAL)
ElseIf vNewValue = 1 Then
Call SetThreadPriority(uThread.Handle, THREAD_PRIORITY_ABOVE_NORMAL)
ElseIf vNewValue = 2 Then
Call SetThreadPriority(uThread.Handle, THREAD_PRIORITY_HIGHEST)
End IfEnd Property
Private Sub Class_Terminate()On Error Resume Next
Call TerminateThread(uThread.Handle, 0)End Sub
---------------------在主程序中---------------------
Dim myThreadTop As New clsThreads, myThreadBottom As New clsThreadsOn Error Resume Next
With myThreadTop
.Initialize AddressOf FlickerTop
.Enabled = True
End With
'处理其他程序
...'注意使用后释放资源
Set myThreadTop = Nothing
Set myThreadBottom = Nothing