bas/modBasico.bas

   1 Attribute VB_Name = "modBasico"
   2 Option Explicit
   3 ' http://support.microsoft.com/?scid=kb%3Ben-us%3B231298&x=6&y=17
   4 Private Type FILETIME
   5     dwLowDateTime As Long
   6     dwHighDateTime As Long
   7 End Type
   8 Private Const WAIT_OBJECT_0& = 0
   9 Private Const INFINITE = &HFFFF
  10 Private Const ERROR_ALREADY_EXISTS = 183&
  11 Private Const QS_HOTKEY& = &H80
  12 Private Const QS_KEY& = &H1
  13 Private Const QS_MOUSEBUTTON& = &H4
  14 Private Const QS_MOUSEMOVE& = &H2
  15 Private Const QS_PAINT& = &H20
  16 Private Const QS_POSTMESSAGE& = &H8
  17 Private Const QS_SENDMESSAGE& = &H40
  18 Private Const QS_TIMER& = &H10
  19 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)
  20 Private Declare Function CreateWaitableTimer _
  21                 Lib "kernel32" _
  22                 Alias "CreateWaitableTimerA" (ByVal lpSemaphoreAttributes As Long, _
  23                                               ByVal bManualReset As Long, _
  24                                               ByVal lpName As String) As Long
  25 Private Declare Function SetWaitableTimer _
  26                 Lib "kernel32" (ByVal hTimer As Long, _
  27                                 lpDueTime As FILETIME, _
  28                                 ByVal lPeriod As Long, _
  29                                 ByVal pfnCompletionRoutine As Long, _
  30                                 ByVal lpArgToCompletionRoutine As Long, _
  31                                 ByVal fResume As Long) As Long
  32 Private Declare Function CloseHandle _
  33                 Lib "kernel32" (ByVal hObject As Long) As Long
  34 Private Declare Function MsgWaitForMultipleObjects _
  35                 Lib "user32" (ByVal nCount As Long, _
  36                               pHandles As Long, _
  37                               ByVal fWaitAll As Long, _
  38                               ByVal dwMilliseconds As Long, _
  39                               ByVal dwWakeMask As Long) As Long
  40 Public Declare Function ShellExecute _
  41                Lib "shell32.dll" _
  42                Alias "ShellExecuteA" (ByVal hWnd As Long, _
  43                                       ByVal lpOperation As String, _
  44                                       ByVal lpFile As String, _
  45                                       ByVal lpParameters As String, _
  46                                       ByVal lpDirectory As String, _
  47                                       ByVal nShowCmd As Long) As Long
  48 'Tomado de http://abstractvb.com/code.asp?A=939
  49 Public Declare Function SetTimer _
  50                Lib "user32" (ByVal hWnd As Long, _
  51                              ByVal nIDEvent As Long, _
  52                              ByVal uElapse As Long, _
  53                              ByVal lpTimerFunc As Long) As Long
  54 Public Declare Function KillTimer _
  55                Lib "user32" (ByVal hWnd As Long, _
  56                              ByVal nIDEvent As Long) As Long
  57
  58 Public Sub Esperar(lNumberOfSeconds As Single)
  59     '<EhHeader>
  60     On Error GoTo Esperar_Err
  61     '</EhHeader>
  62     Dim ft As FILETIME
  63     Dim lBusy As Long
  64     Dim dblDelay As Double
  65     Dim dblDelayLow As Double
  66     Dim dblUnits As Double
  67     Dim hTimer As Long
  68     hTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer")
  69
  70     If Err.LastDllError <> ERROR_ALREADY_EXISTS Then
  71         ft.dwLowDateTime = -1
  72         ft.dwHighDateTime = -1
  73         SetWaitableTimer hTimer, ft, 0, 0, 0, 0
  74     End If
  75
  76     dblUnits = CDbl(&H10000) * CDbl(&H10000)
  77     dblDelay = CDbl(lNumberOfSeconds) * 1000 * 10000
  78     ft.dwHighDateTime = -CLng(dblDelay / dblUnits) - 1
  79     dblDelayLow = -dblUnits * (dblDelay / dblUnits - Fix(dblDelay / dblUnits))
  80
  81     If dblDelayLow < CDbl(&H80000000) Then
  82         dblDelayLow = dblUnits + dblDelayLow
  83         ft.dwHighDateTime = ft.dwHighDateTime + 1
  84     End If
  85
  86     ft.dwLowDateTime = CLng(dblDelayLow)
  87     SetWaitableTimer hTimer, ft, 0, 0, 0, False
  88
  89     Do
  90         lBusy = MsgWaitForMultipleObjects(1, hTimer, False, INFINITE, QS_ALLINPUT&)
  91
  92         DoEvents
  93     Loop Until lBusy = WAIT_OBJECT_0
  94
  95     ' Close the handles when you are done with them.
  96     CloseHandle hTimer
  97     '<EhFooter>
  98     Exit Sub
  99 Esperar_Err:
 100     Controlar_Error Erl, Err.Description, "Reseter.modBasico.Esperar"
 101     Resume Next
 102     '</EhFooter>
 103 End Sub