GFWait/GFWait.frm

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.CommandButton Command1
      Caption         =   "Command1"
      Height          =   615
      Left            =   420
      TabIndex        =   0
      Top             =   2040
      Width           =   2775
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2000, 2001 by Louis.
'
'NOTE: the smallest interruption time is 10 ms.
'If wanting to interrupt for a shorter time, remove 'Call Sleep(10)'.
'NOTE: program events will still appear if using this function to interrupt the program.
'
'GFWait
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Command1_Click()
    'on error resume next
    Debug.Print "Timer START"
    Call GFWait(30)
    Debug.Print "Timer STOP"
End Sub

Private Sub GFWait(ByVal WaitTime As Single)
    'on error resume next 'stays in DoEvents‑loop for WaitTime seconds, even if midnight has passed or OS time was changed
    Dim TimerUnchanged As Single
    Dim TimerNew As Single
    Dim TimerOld As Single
    'preset
    TimerUnchanged = Timer
ReDo:
    'verify
    If WaitTime < 0 Then WaitTime = 0
    If WaitTime > (60! * 60! * 24!) Then WaitTime = (60! * 60! * 24!)
    'begin
    TimerOld = GFWait_Timer(TimerUnchanged) 'preset (important)
    TimerNew = GFWait_Timer(TimerUnchanged) + WaitTime
    Do

        If Abs(GFWait_Timer(TimerUnchanged) ‑ TimerOld) > 1! Then 'use Abs() to get 'distance'
            WaitTime = WaitTime ‑ (TimerOld ‑ TimerUnchanged)
            GoTo ReDo: 'OS time changed by user
        End If
        If GFWait_Timer(TimerUnchanged) > TimerNew Then
            Exit Do 'time to wait passed
        End If
        TimerOld = GFWait_Timer(TimerUnchanged)
        Call Sleep(10) 'decrease CPU usage
        DoEvents
    Loop
End Sub

Private Function GFWait_Timer(ByVal TimerUnchanged As Single) As Single
    'on error resume next 'to be used by GFWait() only
    If Not (Timer < TimerUnchanged) Then 'Timer may be equal to TimerUnchanged
        GFWait_Timer = Timer
    Else
        GFWait_Timer = Timer + (60! * 60! * 24!)
    End If
End Function


[END OF FILE]