'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
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
解决方案 »
- 送分100分:text1.text = rst1.fields("姓名") 时出现无效使用NULL的提示
- 请问vb如何实现像超级兔子一样的自动更新,谢谢
- 请问如何将CSV文件中的数据导入listview以及将listview中的数据导入CSV文件啊.
- 请问什么表格控件可以根据表格内容自动调整单元格大小,使内容完全显示?
- 动态加载控件?
- 穷人提问:数据类型不匹配??
- 如何在一个文本框内将鼠标右击事件屏蔽掉?
- 如何获得COUNT(*)的值?
- <VB.Netfans之初露锋芒风云榜>"我很菜,但是我不赖",挑战自我!快快参加!来者有分!
- 如何编写VB 帮助文件?
- 如何截获指定程序的IP数据包!
- 怎样判断电脑是否能在线(是否能连接到internet)?
那个例子是VB5的。
但VB6就是不能用!