Attribute VB_Name = "mod_DoEventsEx"
' Copyright (C) 2003-2007 Jan Vorel
' This program is free software; you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation; either version 2 of the License, or
' (at your option) any later version.

' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU General Public License for more details.

' You should have received a copy of the GNU General Public License
' along with this program; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

' If you have any questions, suggestions or bug reports about this product,
' contact me: info@ctuser.net; Do not contact me about general B.A.S.I.C.
' language or A.P.I. issues

' Please note any call to DoEventsEx will always delay ~ (( 100ms ) + x*25 )


Option Explicit
Option Base 0

Private Const SleepValueHigh As Long = 100&
Private Const SleepValueLow As Long = 25&

#If (DoEventsEx_FlagA And &H171&) <> 0& Or DoEventsEx_FlagA = 0& Then
  Private Declare Function GetTickCount Lib "kernel32" () As Long
  #End If

#If (DoEventsEx_FlagA And &H1041&) <> &H0& Or DoEventsEx_FlagA = 0& Then
  'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  
  Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
    End Type
  
  Private Declare Function CreateWaitableTimerA Lib "kernel32" (ByVal lpSemaphoreAttributes As Long, ByVal bManualReset As Long, lpName As Any) As Long
  Private Declare Function CreateWaitableTimerW Lib "kernel32" (ByVal lpSemaphoreAttributes As Long, ByVal bManualReset As Long, lpName As Any) As Long
  Private Declare Function SetWaitableTimer Lib "kernel32" (ByVal hTimer As Long, lpDueTime As FILETIME, ByVal lPeriod As Long, ByVal pfnCompletionRoutine As Long, ByVal lpArgToCompletionRoutine As Long, ByVal fResume As Long) As Long
  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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
  #End If

#If (DoEventsEx_FlagA And &H1001&) = &H1001& Then
  Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
  Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
  #End If

'#DoEventsEx_FlagA
' 0/1 = DoeventsEx
'  10 = DoEventsEx_GetElapsedTime
'  20 = DoEventsEx_IsTickCountElapsed
'  40 = DoEventsEx_GetTickCount
' x20 = (100) DoEventsEx_SleepPeriodical (*200 ms)
' f20 = (f00) DoEventsEx_SleepPeriodical (option)
'1001 = (1000) WaitOnProgram
'2000 = WaitForCustom

#If (DoEventsEx_FlagA And 1&) = 1& Or DoEventsEx_FlagA = 0 Then
  Public Sub DoEventsEx(ByVal TimeIntervalMs As Long, Optional ByVal FirstTickValue As Long = -1&)
    
    Static xLong1 As Long
    
'    Sleep 5000&
    
    If TimeIntervalMs > SleepValueHigh Or FirstTickValue = -1& Then
      If FirstTickValue = -1& Then
        FirstTickValue = GetTickCount And &H3FFFFFFF
        End If
      DoEventsEx_Sleep SleepValueHigh
      Do
        xLong1 = GetTickCount And &H3FFFFFFF
        If xLong1 < FirstTickValue Then
          xLong1 = TimeIntervalMs - (xLong1 + &H40000000 - FirstTickValue)
          Else
          xLong1 = TimeIntervalMs - (xLong1 - FirstTickValue)
          End If
          
        If xLong1 > 0& Then
          If xLong1 > SleepValueHigh Then xLong1 = SleepValueHigh
          DoEventsEx_Sleep xLong1
          Else
          Exit Do
          End If
        Loop
      Else
      DoEventsEx_Sleep TimeIntervalMs
      End If
    End Sub
  #End If

#If (DoEventsEx_FlagA And &H10&) = &H10& Then
  Public Function DoEventsEx_GetElapsedTime(ByVal FirstTickCountValue As Long) As Long
    Static xLong1 As Long
    xLong1 = GetTickCount And &H3FFFFFFF
    If xLong1 < FirstTickCountValue Then
      DoEventsEx_GetElapsedTime = xLong1 + &H40000000 - FirstTickCountValue
      Else
      DoEventsEx_GetElapsedTime = (xLong1 - FirstTickCountValue)
      End If
    End Function
  #End If

#If (DoEventsEx_FlagA And &H40&) = &H40 Then
  Public Function DoEventsEx_GetTickCount() As Long
    DoEventsEx_GetTickCount = GetTickCount And &H3FFFFFFF
    End Function
  #End If
  
#If (DoEventsEx_FlagA And &H20) = &H20 Then
  Public Function DoEventsEx_IsTickCountElapsed(ByVal FirstTickCountValue As Long, ByVal TimeIntervalMs As Long) As Boolean
    Static xLong1 As Long
    xLong1 = GetTickCount And &H3FFFFFFF
    If xLong1 < FirstTickCountValue Then
      DoEventsEx_IsTickCountElapsed = (xLong1 + &H40000000 > FirstTickCountValue + TimeIntervalMs)
      Else
      DoEventsEx_IsTickCountElapsed = (xLong1 > FirstTickCountValue + TimeIntervalMs)
      End If
    End Function
  #End If


''''' define as 220 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#If Not (DoEventsEx_FlagA And &HF00&) = &H0& And ((DoEventsEx_FlagA And &H20&) = &H20&) Then
  Public Sub DoEventsEx_SleepPeriodical()
    Static xLong1 As Long
  
    If DoEventsEx_IsTickCountElapsed(xLong1, AnimTimer) Then
      'Debug.Print , "MustWait", Timer
      DoEventsEx_Sleep SleepValueLow
      xLong1 = GetTickCount And &H3FFFFFFF
      End If
    End Sub
  #End If





#If (DoEventsEx_FlagA And &H1001&) = &H1001& Then
  Public Function WaitOnProgram(ByVal ProgramID As Double, Optional ByVal SilentWaitInterval As Long = 5000&) As Long
    If Not ProgramID = 0# Then
      ProgramID = OpenProcess(&H1F0FFF, False, ProgramID)
      DoEventsEx 1000&
      Do While (WaitForSingleObject(ProgramID, 100&) = 258&)
        DoEventsEx SilentWaitInterval
        Loop
      Call CloseHandle(ProgramID)
      End If
    End Function
  #End If

#If (DoEventsEx_FlagA And &H41&) <> 0& Or DoEventsEx_FlagA = 0 Then
  Public Sub DoEventsEx_Sleep(ByVal IntervalMS As Long)
    Dim xType1 As FILETIME
    Dim xLong1 As Long
  
    If IsUnicode Then
      xLong1 = CreateWaitableTimerW(0, True, 0&)
      Else
      xLong1 = CreateWaitableTimerA(0, True, 0&)
      End If
    xType1.dwLowDateTime = -1&
    xType1.dwHighDateTime = -1&
    Call SetWaitableTimer(xLong1, xType1, 0&, 0&, 0&, 0&)
    xType1.dwLowDateTime = IntervalMS * -10000&
    Call SetWaitableTimer(xLong1, xType1, 0&, 0&, 0&, False)
    Do Until MsgWaitForMultipleObjects(1&, xLong1, False, -1&, 255&) = 0&
      DoEvents
      Loop
    DoEvents
    CloseHandle xLong1
    End Sub
  #End If
