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 2   hTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer")
  69
  70 4   If Err.LastDllError <> ERROR_ALREADY_EXISTS Then
  71 6       ft.dwLowDateTime = -1
  72 8       ft.dwHighDateTime = -1
  73 10      SetWaitableTimer hTimer, ft, 0, 0, 0, 0
  74     End If
  75
  76 12  dblUnits = CDbl(&H10000) * CDbl(&H10000)
  77 14  dblDelay = CDbl(lNumberOfSeconds) * 1000 * 10000
  78 16  ft.dwHighDateTime = -CLng(dblDelay / dblUnits) - 1
  79 18  dblDelayLow = -dblUnits * (dblDelay / dblUnits - Fix(dblDelay / dblUnits))
  80
  81 20  If dblDelayLow < CDbl(&H80000000) Then
  82 22      dblDelayLow = dblUnits + dblDelayLow
  83 24      ft.dwHighDateTime = ft.dwHighDateTime + 1
  84     End If
  85
  86 26  ft.dwLowDateTime = CLng(dblDelayLow)
  87 28  SetWaitableTimer hTimer, ft, 0, 0, 0, False
  88
  89     Do
  90 30      lBusy = MsgWaitForMultipleObjects(1, hTimer, False, INFINITE, QS_ALLINPUT&)
  91
  92 32      DoEvents
  93 34  Loop Until lBusy = WAIT_OBJECT_0
  94
  95     ' Close the handles when you are done with them.
  96 36  CloseHandle hTimer
  97     '<EhFooter>
  98     Exit Sub
  99 Esperar_Err:
 100     Controlar_Error Erl, Err.Description, "Reseter.modBasico.Esperar.Ref 13/01/2008 : 09:06:25 a.m."
 101     Resume Next
 102     '</EhFooter>
 103 End Sub