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