Vi sarà capitato di dover usare la famosa Api
Sleep che
consente di effettuare una pausa nell'esecuzione del vostro codice.
Lo svantaggio di questa funzione è che il processo, durante
il periodo di pausa, è totalmente congelato quindi le vostre
form smettono temporaneamente di funzionare e sembrano come bloccate.
Per ovviare a questo terribile inconveniente ho cercato molto in giro per la
rete finché ho trovato un fantastico modulo BAS (di cui vi posto il sorgente)
che includo in quasi tutti i miei progetti VB6.
L'autore del modulo si chiama
Sergey Merzlikin
e
cliccando qui potete visitare il suo sito web.
MsgWaitObj rimpiazza la funzion Sleep
che al contrario di essa, non blocca l'elaborazione dei messaggi di thread.
Invece di usare
Sleep potremmo usare:
MsgWaitObj dwMilliseconds
Es.:
MsgWaitObj 1000 ' Effettua una pausa di 1 secondo
per l'uso di altre funzioni avanzate di wait nel vostro
codice VB6 vi invito a visitare il sito dell'autore.
Option Explicit
'********************************************
'* (c) 1999-2000 Sergey Merzlikin *
'********************************************
Private Const STATUS_TIMEOUT = &H102&
Private Const INFINITE = -1& ' Infinite interval
Private Const QS_KEY = &H1&
Private Const QS_MOUSEMOVE = &H2&
Private Const QS_MOUSEBUTTON = &H4&
Private Const QS_POSTMESSAGE = &H8&
Private Const QS_TIMER = &H10&
Private Const QS_PAINT = &H20&
Private Const QS_SENDMESSAGE = &H40&
Private Const QS_HOTKEY = &H80&
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 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 GetTickCount Lib "kernel32" () As Long
' The MsgWaitObj function replaces Sleep,
' WaitForSingleObject, WaitForMultipleObjects functions.
' Unlike these functions, it
' doesn't block thread messages processing.
' Using instead Sleep:
' MsgWaitObj dwMilliseconds
' Using instead WaitForSingleObject:
' retval = MsgWaitObj(dwMilliseconds, hObj, 1&)
' Using instead WaitForMultipleObjects:
' retval = MsgWaitObj(dwMilliseconds, hObj(0&), n),
' where n - wait objects quantity,
' hObj() - their handles array.
Public Function MsgWaitObj(Interval As Long, _
Optional hObj As Long = 0&, _
Optional nObj As Long = 0&) As Long
Dim T As Long, T1 As Long
If Interval <> INFINITE Then
T = GetTickCount()
On Error Resume Next
T = T + Interval
' Overflow prevention
If Err <> 0& Then
If T > 0& Then
T = ((T + &H80000000) _
+ Interval) + &H80000000
Else
T = ((T - &H80000000) _
+ Interval) - &H80000000
End If
End If
On Error GoTo 0
' T contains now absolute time of the end of interval
Else
T1 = INFINITE
End If
Do
If Interval <> INFINITE Then
T1 = GetTickCount()
On Error Resume Next
T1 = T - T1
' Overflow prevention
If Err <> 0& Then
If T > 0& Then
T1 = ((T + &H80000000) _
- (T1 - &H80000000))
Else
T1 = ((T - &H80000000) _
- (T1 + &H80000000))
End If
End If
On Error GoTo 0
' T1 contains now the remaining interval part
If IIf((T1 Xor Interval) > 0&, _
T1 > Interval, T1 < 0&) Then
' Interval expired
' during DoEvents
MsgWaitObj = STATUS_TIMEOUT
Exit Function
End If
End If
' Wait for event, interval expiration
' or message appearance in thread queue
MsgWaitObj = MsgWaitForMultipleObjects(nObj, _
hObj, 0&, T1, QS_ALLINPUT)
' Let's message be processed
DoEvents
If MsgWaitObj <> nObj Then Exit Function
' It was message - continue to wait
Loop
End Function