如何让一个死循环运行得更久一些，而不当机？

Question

Private Sub Timer_Timer()
wait 5
End sub
Private Sub wait(ByVal X As Long)
Dim start, finish
   start = Timer
   finish = start + X
   Do While start < finish
      start = Timer
      DoEvents
      If GetAsyncKeyState(17) <> 0 And GetAsyncKeyState(71) <> 0 Then ‘CTRL+G中断运行
        Timer.Enabled = False
        Exit Sub
      End If
   Loop
End Sub这个程序运行3-4小时没问题，4小时以上就停止响应！

Answer 1

直接用Timer控件不行吗?为什么一定要把CTRL+G的检查放到循环中呢?

Answer 2

Private Sub wait(ByVal X As double)

Answer 3

//直接用Timer控件不行吗?
//为什么一定要把CTRL+G的检查放到循环中呢?CTRL+G是为了中断程序运行，让timer.enable=fasle，来停止时间控件！

Answer 4

//Private Sub wait(ByVal X As double)为什么？

Answer 5

Long类型到一定的长度就溢出了,Double比Long长.

Answer 6

//Long类型到一定的长度就溢出了,Double比Long长.5秒不会溢出的，而且程序要到4小时后才会出问题！

Answer 7

用这么做的必要嘛？
用Timer控件或Sleep函数都可以等很长时间啊，而且也不会占用那么多系统资源

Answer 8

把wait里的代码改后直接放到timer里不行吗？
为什么要多个wait过程

Answer 9

因为
Private Sub Timer_Timer()
wait 5
…………这里省略了N行代码…………
End sub

Answer 10

这样改：
Private Sub wait(byval TT as Long)
dim Start as double
dim Finsh as double
Start= cdbl(Timegettime)/100
Finsh=Start+cdbl(TT)/100
Do While Start< Finsh
   start = cdbl(Timergettime)/100
   DoEvents
   ...
Loop
End Sub
如果以前你的程序可以运行4个小时，现在因该可以运行400个小时了吧，呵呵

Answer 11

改成这样:
Public Sub wait(TT As Single)
Dim Start As Single
Start = Timer 
Do While Timer < Start + TT
      DoEvents 
Loop
End Sub

Answer 12

Bug：
    用 Timer 对象来延时，如果遇到跨午夜，Timer 将复位，你的程序将陷入死循环，直至次日午夜前。(你大概常常在傍晚开始试验。）Private Declare Function GetTickCount Lib "kernel32" Alias "GetTickCount" () As LongPrivate Sub wait(ByVal X As Long)
Dim finish As Long
   Timer1.Enabled = False
   finish = GetTickCount() + X * 1000 
   Do While finish < GetTickCount()
      DoEvents
      If GetAsyncKeyState(17) <> 0 And GetAsyncKeyState(71) <> 0 Then ‘CTRL+G中断运行
        Exit Sub
      End If
   Loop
   Timer1.Enabled = True
End Sub注意：GetTickCount()是用 Long 记录操作系统运行后的毫秒数，几十天也就满了。如果要连续运行那么长时间，可以检查 GetTickCount() 是否小于 X * 1000。如果是，调整 finish（减去可表示的最大正数）。

Answer 13

最标准的是这个：
Private Declare Function timeGetTime Lib "winmm.dll" () As LongDim SaveTime As Double
Dim OverTime As Long 
OverTime = 2000 '延迟2000毫秒
SaveTime = timeGetTime '记下开始时的时间
Do Until timeGetTime - SaveTime >= OverTime '延迟
   DoEvents
Loop

Answer 14

当延时 X 不超过 49.7 天时，在系统时钟回零时能自动调整的代码：Private Declare Function GetTickCount Lib "kernel32" Alias "GetTickCount" () As LongPrivate Sub wait(ByVal X As Long)
Dim Start As Long
   Timer1.Enabled = False
   Start = GetTickCount()
   Do While GetTickCount() - Start <= X * 1000
      DoEvents
      If GetAsyncKeyState(17) <> 0 And GetAsyncKeyState(71) <> 0 Then ‘CTRL+G中断运行
        Exit Sub
      End If
   Loop
   Timer1.Enabled = True
End Sub和网络非狐的原理一样。

Answer 15

//你可以这样试一下：
//将机器的时钟改为 23:59，然后运行你的程序。不到 1 分钟就死。经测试没有出现你所说的情况！另外的我的程序中最长延时是5秒，不过程序中有多个wait 5。

Answer 16

终于找到了！
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Const WAIT_ABANDONED& = &H80&
Private Const WAIT_ABANDONED_0& = &H80&
Private Const WAIT_FAILED& = -1&
Private Const WAIT_IO_COMPLETION& = &HC0&
Private Const WAIT_OBJECT_0& = 0
Private Const WAIT_OBJECT_1& = 1
Private Const WAIT_TIMEOUT& = &H102&
Private Const INFINITE = &HFFFF
Private Const ERROR_ALREADY_EXISTS = 183&
Private Const QS_HOTKEY& = &H80
Private Const QS_KEY& = &H1
Private Const QS_MOUSEBUTTON& = &H4
Private Const QS_MOUSEMOVE& = &H2
Private Const QS_PAINT& = &H20
Private Const QS_POSTMESSAGE& = &H8
Private Const QS_SENDMESSAGE& = &H40
Private Const QS_TIMER& = &H10
Private Const QS_MOUSE& = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Private Const QS_INPUT& = (QS_MOUSE Or QS_KEY)
Private Const QS_ALLEVENTS& = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or QS_HOTKEY)
Private Const QS_ALLINPUT& = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY)Private Declare Function CreateWaitableTimer Lib "kernel32" Alias "CreateWaitableTimerA" (ByVal lpSemaphoreAttributes As Long, ByVal bManualReset As Long, ByVal lpName As String) As Long
Private Declare Function OpenWaitableTimer Lib "kernel32" Alias "OpenWaitableTimerA" (ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, ByVal lpName As String) As Long
Private Declare Function SetWaitableTimer Lib "kernel32" (ByVal hTimer As Long, lpDueTime As FILETIME, ByVal lPeriod As Long, _
    ByVal pfnCompletionRoutine As Long, ByVal lpArgToCompletionRoutine As Long, ByVal fResume As Long) As Long
Private Declare Function CancelWaitableTimer Lib "kernel32" (ByVal hTimer As Long)
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function MsgWaitForMultipleObjects Lib "user32" (ByVal nCount As Long, pHandles As Long, ByVal fWaitAll As Long, _
    ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long'************************************************************************************Public hTimer As Long            '定时器句柄
Public Sub Wait(lNumberOfSeconds As Long)
    Dim ft As FILETIME
    Dim lBusy As Long
    Dim lRet As Long
    Dim dblDelay As Double
    Dim dblDelayLow As Double
    Dim dblUnits As Double
    Dim ErrCode As Long
    On Error GoTo HELL
    hTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer")
    If Err.LastDllError = ERROR_ALREADY_EXISTS Then
        ErrCode = GetLastError()
        If ErrCode <> 0 Then
           ' WriteErrLog Nothing, "Modinitial.Wait", 418, "Sysrem Error, Code: " & ErrCode
            Err.Clear
        End If
        ' If the timer already exists, it does not hurt to open it
        ' as long as the person who is trying to open it has the
        ' proper access rights.
    Else
        ft.dwLowDateTime = -1
        ft.dwHighDateTime = -1
        lRet = SetWaitableTimer(hTimer, ft, 0, 0, 0, 0)
    End If
    ' Convert the Units to nanoseconds.
    dblUnits = CDbl(&H10000) * CDbl(&H10000)
    dblDelay = CDbl(lNumberOfSeconds) * 1000 * 10000
    ' By setting the high/low time to a negative number, it tells
    ' the Wait (in SetWaitableTimer) to use an offset time as
    ' opposed to a hardcoded time. If it were positive, it would
    ' try to convert the value to GMT.
    ft.dwHighDateTime = -CLng(dblDelay / dblUnits) - 1
    dblDelayLow = -dblUnits * (dblDelay / dblUnits - _
        Fix(dblDelay / dblUnits))
    If dblDelayLow < CDbl(&H80000000) Then
        ' &H80000000 is MAX_LONG, so you are just making sure
        ' that you don't overflow when you try to stick it into
        ' the FILETIME structure.
        dblDelayLow = dblUnits + dblDelayLow
    End If
    ft.dwLowDateTime = CLng(dblDelayLow)
    lRet = SetWaitableTimer(hTimer, ft, 0, 0, 0, False)
    Do
        ' QS_ALLINPUT means that MsgWaitForMultipleObjects will
        ' return every time the thread in which it is running gets
        ' a message. If you wanted to handle messages in here you could,
        ' but by calling Doevents you are letting DefWindowProc
        ' do its normal windows message handling---Like DDE, etc.
        lBusy = MsgWaitForMultipleObjects(1, hTimer, False, _
            INFINITE, QS_ALLINPUT&)
        DoEvents
'***********我加的东西
      If GetAsyncKeyState(17) <> 0 And GetAsyncKeyState(71) <> 0 Then 'CTRL+G中断运行
        Timer.Enabled = False
        Exit Sub
      End If
'***********我加的东西
    Loop Until lBusy = WAIT_OBJECT_0
    ' Close the handles when you are done with them.
    CloseHandle hTimer
    Exit Sub
HELL:
  ErrCode = GetLastError()
  'WriteErrLog Nothing, "Modinitial.Wait", 476, "Sysrem Error, Code: " & ErrCode
  Err.Clear
  Resume Next
End Sub