VB延时模块，6种做法汇总

87 阅读 0 评论 58 点赞

我是靠谱客的博主大力热狗，最近开发中收集的这篇文章主要介绍VB延时模块，6种做法汇总，觉得挺不错的，现在分享给大家，希望可以做个参考。

概述

Option Explicit
'延时模块，根据网上资料加以整理改写，共6种做法及参数可选

'要点是：sleep(较长时间)会造成假死甚至崩溃
'反复读取和比较时间则导致占用大量CPU
'doevents能够在sleep或反复循环的“间隙”响应其他事件或操作
'再加上sleep 1，就基本上不占用CPU了
'但要防止重复响应造成类似于“层叠事件”或多个过程彼此“交错”运行，最好把不允许响应的功能暂时禁用
'不同的API可能存在精度以及硬件“开销”的差别
'可能QueryPerformanceCounter的精度最高，而timeGetTime高于GetTickCount？

'可能发生：使用某些语句退出程序或关闭窗体后，延时模块代码还在运行
'可以讨论：什么情况用延时，什么情况用timer控件，同步异步？
'但异步其实也是线性执行的？
'以及：过程交错运行？堆栈？
'又：msgbox时所有过程暂停了？拖动窗体时也是？导致延时不正确？

'最近一次修改：2016-4-16

Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetTickCount Lib "Kernel32" () As Long '系统启动以来的毫秒数
Private Declare Function timeGetTime Lib "winmm.dll" () As Long '功能好像和GetTickCount一样

'本来的写法：
'Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
'Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
'Private Type LARGE_INTEGER
' lowpart As Long
' highpart As Long
'End Type
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Long

Private Declare Sub GetSystemTime Lib "Kernel32" (lpSystemTime As SYSTEMTIME)
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type

Private Declare Function GetInputState Lib "user32" () As Long

Public Sub manyDelays(ByVal milliSeconds As Long, _
Optional ByVal whichWay As Byte = 6, _
Optional ByVal anotherParameter As Byte = 1)
'whichWay默认值6，用GetSystemTime函数，没有归零的问题
'sleep函数适用于短暂延时或不用随时响应用户也没有即时写屏的情况
'调用语句如：manyDelays 500 '延时500毫秒，后面的参数使用默认值

If milliSeconds <= 0 Then Exit Sub

Select Case whichWay
Case 1
SlpDelay milliSeconds, anotherParameter
Case 2
TmrDelay milliSeconds, anotherParameter
Case 3
GtcDelay milliSeconds, anotherParameter
Case 4
TgtDelay milliSeconds, anotherParameter
Case 5
QpcDelay milliSeconds, anotherParameter
Case 6
GstDelay milliSeconds, anotherParameter
Case Else

End Select
End Sub

Private Sub SlpDelay(mlS As Long, anotherParameter As Byte)
goDoevents anotherParameter
Sleep mlS
End Sub

Private Sub TmrDelay(mlS As Long, anotherParameter As Byte)
Dim TStart As Long
TStart = Timer * 1000&
While (Timer * 1000& - TStart) < mlS
'跨午夜时归零，不处理
If Timer * 1000& < TStart Then Exit Sub
goDoevents anotherParameter
goSleep1 anotherParameter
Wend
End Sub

Private Sub GtcDelay(mlS As Long, anotherParameter As Byte)
Dim TStart As Long
TStart = GetTickCount
While (GetTickCount - TStart) < mlS
'接近第25天（第50天？）时归零，不处理
If GetTickCount < TStart Then Exit Sub
goDoevents anotherParameter
goSleep1 anotherParameter
Wend
End Sub

Private Sub TgtDelay(mlS As Long, anotherParameter As Byte)
Dim TStart As Long
TStart = timeGetTime
While (timeGetTime - TStart) < mlS
'接近第25天（第50天？）时归零，不处理
If timeGetTime < TStart Then Exit Sub
goDoevents anotherParameter
goSleep1 anotherParameter
Wend
End Sub

Private Sub QpcDelay(mlS As Long, anotherParameter As Byte)
Dim TStart As Currency, TNow As Currency
Dim Freq As Currency

'安装的硬件不支持高精度计时器
If QueryPerformanceCounter(TStart) = 0 Then
MsgBox "不能使用QueryPerformanceCounter功能"
Exit Sub
End If

QueryPerformanceFrequency Freq
Do
goDoevents anotherParameter
goSleep1 anotherParameter
QueryPerformanceCounter TNow
'系统休眠后恢复，可能归零？不处理
If TNow < TStart Then Exit Sub
Loop While (TNow - TStart) / Freq * 1000@ < mlS
End Sub

Private Sub GstDelay(mlS As Long, anotherParameter As Byte)
'如果要避免其他几个函数的“归零”问题，可以使用本函数
Dim TStart As SYSTEMTIME, TNow As SYSTEMTIME
GetSystemTime TStart
Do
goDoevents anotherParameter
goSleep1 anotherParameter
GetSystemTime TNow
' Loop While (日期差值的毫秒 + 时间差值的毫秒 + 毫秒差值) < mlS
Loop While (DateDiff("s", DateSerial(TStart.wYear, TStart.wMonth, TStart.wDay), _
DateSerial(TNow.wYear, TNow.wMonth, TNow.wDay)) * 1000& + _
DateDiff("s", TimeSerial(TStart.wHour, TStart.wMinute, TStart.wSecond), _
TimeSerial(TNow.wHour, TNow.wMinute, TNow.wSecond)) * 1000& + _
(TNow.wMilliseconds - TStart.wMilliseconds)) < mlS
End Sub

Private Sub goDoevents(anotherParameter As Byte)
Select Case anotherParameter
Case 0, 3
'不doevents
Case 1, 4
DoEvents
Case 2, 5
If GetInputState Then DoEvents
Case Else

End Select
End Sub

Private Sub goSleep1(anotherParameter As Byte)
If anotherParameter < 3 Then Sleep 1
End Sub