WaitSeconds.vb

' Wait function for VBA Excel
#If VBA7 Then
	Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
#Else        
	Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
#End If

' idea from ' http://www.fmsinc.com/microsoftaccess/modules/examples/avoiddoevents.asp
Sub WaitSeconds(intSeconds As Integer)
    Dim datTime As Date
    Dim sStatusBarInitial As String
    Dim k As Integer
    Dim bScreenUpdatingInitial As Boolean
    Dim CursorInitial As Double
    
    With Application
        bScreenUpdatingInitial = .ScreenUpdating
        CursorInitial = .Cursor
        sStatusBarInitial = IIf(.StatusBar <> False, .StatusBar, vbNullString)
        
        .ScreenUpdating = False
        .Cursor = xlWait
    End With
    
    datTime = DateAdd("s", intSeconds, Now)
    Do
        ' 255 chars is limit of status bar
        If Len(Application.StatusBar) + Len(CStr(CStr(intSeconds - k)) & "...") > 255 Then
            Application.StatusBar = Left(Left(sStatusBarInitial, 255 - Len(CStr(intSeconds - k) & "...") - 1) _
                & " " & CStr(intSeconds - k) & "...", 255)
        Else
            Application.StatusBar = sStatusBarInitial & " " & CStr(intSeconds - k) & "..."
        End If
        ' Yield to other programs (better than using DoEvents which eats up all the CPU cycles)
        Sleep 1000
        DoEvents
        k = k + 1
    Loop Until Now >= datTime

    With Application
        .StatusBar = sStatusBarInitial
        .ScreenUpdating = bScreenUpdatingInitial
        .Cursor = CursorInitial
    End With
End Sub