'class modul
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 LongPublic 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 SubPublic Property Get Enabled() As Boolean
    On Error Resume Next
    Enabled = uThread.Enabled
End PropertyPublic 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 If
End PropertyPublic Property Get Priority() As Long
    On Error Resume Next
    Priority = GetThreadPriority(uThread.Handle)
End PropertyPublic 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 If
End PropertyPrivate Sub Class_Terminate()
    On Error Resume Next
    Call TerminateThread(uThread.Handle, 0)
End Sub
'module
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As LongPublic Sub FlickerTop()
Static BgColor As Long
Dim lTick As Long, lCounter As Long    On 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
    Next
End SubPublic Sub FlickerBottom()
Static BgColor As Long
Dim lTick As Long, lCounter As Long    On 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
Next
End Sub
'在一个form中加两个picture和一个command
'* * * * * * * * * * * * * * * * * * * * * * *
'* 程序整理:Scent Lily                      *
'* 程序下载:香水百合园(scentlily.y365.com)  *
'* 留言地址:scentlily.abc.yesite.com        *
'* 上传日期:08/14/2001                      *
'* 请您继续关注香水百合园,有问题或者建议请  *
'* 给我发E-Mail,或者请去留言版留言!谢谢!  *
'* * * * * * * * * * * * * * * * * * * * * * *Option ExplicitPrivate Sub Command1_Click()
Dim myThreadTop As New clsThreads, myThreadBottom As New clsThreads    On Error Resume Next
    With myThreadTop
        .Initialize AddressOf FlickerTop
        .Enabled = True
    End With
    
    With myThreadBottom
        .Initialize AddressOf FlickerBottom
        .Enabled = True
    End With    MsgBox "请注意看画面上的两个图象框!"    Set myThreadTop = Nothing
    Set myThreadBottom = Nothing
End SubPrivate Sub Form_Load()End Sub