VB 多线程'-------------Form-----------------------------------------
Option Explicit
Private Sub Command1_Click()Dim myThreadTop As New clsThreads, myThreadBottom As New clsThreadsOn Error Resume Next
With myThreadTop
.Initialize AddressOf FlickerTop
.Enabled = True
End With
With myThreadBottom
.Initialize AddressOf FlickerBottom
.Enabled = True
End WithMsgBox "Let's wait and see what happens..."Set myThreadTop = Nothing
Set myThreadBottom = NothingEnd Sub
''''''''''''''''''''''''''''''''''''''''''''''''
'---------clsThreads----Class----------------------
Option Explicit
Option Compare Text
Option Base 0Private 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 "创建线程失败!"
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
'------------------------------------------------------------
'--------------Module-------------------------------------------
Option Explicit
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
Public Sub FlickerBottom()Static BgColor As Long
Dim lTick As Long, lCounter As LongOn Error Resume Next
For lCounter = 0 To 5999
If BgColor <> &HFFFF& Then BgColor = &HFFFF& Else BgColor = &HFF0000
Form1.Picture2.BackColor = BgColor
lTick = GetTickCount
While GetTickCount - lTick < 500
Wend
NextEnd Sub
Option Explicit
Private Sub Command1_Click()Dim myThreadTop As New clsThreads, myThreadBottom As New clsThreadsOn Error Resume Next
With myThreadTop
.Initialize AddressOf FlickerTop
.Enabled = True
End With
With myThreadBottom
.Initialize AddressOf FlickerBottom
.Enabled = True
End WithMsgBox "Let's wait and see what happens..."Set myThreadTop = Nothing
Set myThreadBottom = NothingEnd Sub
''''''''''''''''''''''''''''''''''''''''''''''''
'---------clsThreads----Class----------------------
Option Explicit
Option Compare Text
Option Base 0Private 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 "创建线程失败!"
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
'------------------------------------------------------------
'--------------Module-------------------------------------------
Option Explicit
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
Public Sub FlickerBottom()Static BgColor As Long
Dim lTick As Long, lCounter As LongOn Error Resume Next
For lCounter = 0 To 5999
If BgColor <> &HFFFF& Then BgColor = &HFFFF& Else BgColor = &HFF0000
Form1.Picture2.BackColor = BgColor
lTick = GetTickCount
While GetTickCount - lTick < 500
Wend
NextEnd Sub
编译成exe文件后能运行吗?
你可以建立WORD对象进行查询,也可以查询打印任务队列。都很麻烦。