Sleep Functionality - Can you please test my code for efficiency?

[Mousehunter]

Hello!

Yesterday I posted a question received a solution from @John_w who suggested I used a Windows API call (sleep) instead of the VBA Wait function I was trying to use. I did use it and it worked fine.

In a big fat nutshell, I am trying to alter the contents of a cell (adding 1 for instance) based on an input that is Beats per Minute. So the application must sleep for so many seconds per minute each time so that I have the desired outcome.

The problem is that each time I am trying to modify a cell, a ton of code runs backstage and this slows down everything. My hands are tied because I cannot deactivate the AddIn due to corporate policies. Having that situation in mind, I modified the code so that it keeps track of the Beats per Minute every minute. How many for the 1st minute, how many for the second etc. The more the beats I want the greater the discrepancy between the intended and the actual beats I receive. For instance If I want 255 BPM I receive 233, if I want 84, I receive 79, If I want 60, I receive 58 etc.

Below is the code I use

Option Explicit

#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)
#End If

Dim MinuteCounter As Integer

Sub StartClock()

Dim BPM As Byte, Rythm, TimeLapse As Double, TimeLapseInSeconds
Dim NewCountofBeats As Integer, OldCountofBeats As Integer, LastUsedStatsRow As Integer

If IsEmpty([j4]) Then Exit Sub
Let BPM = [j4]
Let [d4] = 0

Let MinuteCounter = 1
Let OldCountofBeats = 0
Let NewCountofBeats = 0

[a8:d8].Resize([d1].Value).ClearContents
[b2:b3].ClearContents
Let [d1] = 0

Let [b1].Value = "Start"
Let Rythm = 60 / BPM
If [b2].Value = "" Then [b2].Value = Now

Label:
VBA.DoEvents
Let [b3].Value = Now
Let [d4] = [d4] + 1
Sleep CDbl(Rythm) * 1000

If [b1].Value = "Stop" Then
    Let [d1] = MinuteCounter
    Exit Sub
End If

Let TimeLapse = [b4].Value
Let TimeLapseInSeconds = TimeLapse * 86400
If TimeLapseInSeconds \ 60 >= MinuteCounter Then
    NewCountofBeats = [d4].Value
    Let [a7].Offset(MinuteCounter) = BPM
    Let [b7].Offset(MinuteCounter) = MinuteCounter
    Let [c7].Offset(MinuteCounter) = NewCountofBeats - OldCountofBeats
    Let [d7].Offset(MinuteCounter) = 1 - ([c7].Offset(MinuteCounter).Value / [a7].Offset(MinuteCounter).Value)
    Let OldCountofBeats = NewCountofBeats
    Let MinuteCounter = MinuteCounter + 1
End If

GoTo Label

End Sub


Sub StopClock()

Let [b1].Value = "Stop"
Let [d1] = MinuteCounter

End Sub


Sub Reset_Timer()
Dim LastUsedStatsRow As Integer

Let [b1].Value = "Stop"
Let [d4] = 0
Let [d1] = MinuteCounter

[a8:d8].Resize([d1].Value).ClearContents
[b2:b3].ClearContents

End Sub

And here is a printscreen from the file

Can you please test the code and tell me about the discrepancies in your PC? Am I doing something wrong or is it the xlam things slowing it down?

Please email me at [email address removed] to receive the file if you want to give it a try using my file.

Thanks,

Adam

 

[GWteB]

Hi Adam, to start with, I sincerely hope you are not affected by the wildfires that your country is currently suffering.

Regarding your issue there are two things that come into play. First of all, the resolution of time. Currently, the smallest unit of time used is milliseconds. This resolution is too low for the purpose you are aiming for. In addition, the time required for both the calculations and the display of the results on the worksheet must also be taken into account. Increasing the resolution of time can be accomplished by calling a few other Win-API functions, wrapped into a separate class with some tailor made methods and properties, which in turn can be used to determine the delay of the code being used for calculations and display purposes.
Despite the foregoing, it is almost impossible to simulate the exact number of beats per minute you intended to. Not only the used (as you said impossible to deactivate) AddIn is responsible for this, also other simultaneously running processes on your computer as well as your own behavior (for example, within Excel changing the selected worksheet range or switching worksheets) will have an effect on the final result.

The code for the separate class module I'm talking about is below. Create a class module (within VBE > menu > Insert > Class module) and paste the code below there. Then rename this module to HiResTimer (within VBE press F4 to open properties window, change (Name) from Class1 to HiResTimer).

This goes in a class module, named HiResTimer:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function QueryFrequency Lib "kernel32" Alias "QueryPerformanceFrequency" (lpFrequency As Currency) As Long
    Private Declare PtrSafe Function QueryCounter Lib "kernel32" Alias "QueryPerformanceCounter" (lpPerformanceCount As Currency) As Long
#Else
    Private Declare Function QueryFrequency Lib "kernel32" Alias "QueryPerformanceFrequency" (lpFrequency As Currency) As Long
    Private Declare Function QueryCounter Lib "kernel32" Alias "QueryPerformanceCounter" (lpPerformanceCount As Currency) As Long
#End If

Private Type TLocals
    Frequency   As Currency
    Overhead    As Currency
    Started     As Currency
    Stopped     As Currency
End Type
Private this As TLocals

Private Sub Class_Initialize()
    Dim Count1 As Currency, Count2 As Currency
    QueryFrequency this.Frequency
    QueryCounter Count1
    QueryCounter Count2
    this.Overhead = Count2 - Count1
End Sub

Public Sub StartTimer()
    QueryCounter this.Started
End Sub

Public Sub StopTimer()
    QueryCounter this.Stopped
End Sub

Public Sub ResetTimer()
    this.Started = 0
    this.Stopped = 0
    Me.StartTimer
End Sub

Public Sub Sleep(ByVal argSeconds As Double)
    Dim SleepTimer As HiResTimer
    Set SleepTimer = New HiResTimer
    With SleepTimer
        .StartTimer
        Do While .Elapsed < argSeconds
        Loop
        .StopTimer
    End With
    Set SleepTimer = Nothing
End Sub

Public Property Get Elapsed() As Double
    Dim Timer As Currency
    With this
        If .Stopped = 0 Then
            QueryCounter Timer
        Else
            Timer = .Stopped
        End If
        If .Frequency > 0 Then
            Elapsed = (Timer - .Started - .Overhead) / .Frequency
        End If
    End With
End Property

The code below is a derivative of your own code and it depends on the HiResTimer class module. Note that all ranges are qualified to the active worksheet.

This goes in a standard module:

Public MinuteCounter As Integer


Sub StartClock_NEW()

    Const TWENTYFOURHOURSINSECONDS  As Long = 86400

    Dim BPM As Long, Rythm As Double, TimeLapse As Double
   
    Dim ws As Worksheet, TimeWatch As HiResTimer
    Dim Bool As Boolean, i As Long

    Set ws = ActiveSheet
    With ws
        If Not IsEmpty(.[j4]) Then

            Let BPM = .[j4]
            Let .[d4] = 0
            If .[d1].Value = 0 Then .[d1].Value = 9999
       
            .[a8:d8].Resize(.[d1].Value).ClearContents
            .[b2:b3].ClearContents
            Let .[d1] = 0
            Let .[b1].Value = "Start"

            Set TimeWatch = New HiResTimer

            ' determine estimated duration of loop
            TimeWatch.StartTimer
            For i = 1 To 5
                Bool = .[b1].Value <> "Stop" Or TimeWatch.Elapsed < .[b4].Value * TWENTYFOURHOURSINSECONDS
                Let .[b3].Value = Now
                Let .[d4] = .[d4] + 0
                Let TimeLapse = .[b4].Value
                VBA.DoEvents
            Next i
            Rythm = (60 / BPM) - (TimeWatch.Elapsed / (i - 1))

            ' go for real ...
            Let .[b2].Value = Now
            TimeWatch.ResetTimer
            Do
                If .[b1].Value = "Stop" Then Exit Do
                Let .[b3].Value = Now
                Let .[d4] = .[d4] + 1
                TimeWatch.Sleep Rythm
                Let TimeLapse = .[b4].Value
                VBA.DoEvents
            Loop Until TimeWatch.Elapsed > TimeLapse * TWENTYFOURHOURSINSECONDS
            Let .[b3].Value = Now
        End If
    End With
End Sub

Sub StopClock_NEW()
    With ActiveSheet
        Let .[b1].Value = "Stop"
        Let .[d1] = MinuteCounter
        If .[d1].Value = 0 Then .[d1].Value = 9999
    End With
End Sub

Sub Reset_Timer_NEW()
    With ActiveSheet
        Let .[b1].Value = "Stop"
        Let .[d4] = 0
        Let .[d1] = MinuteCounter

        If .[d1].Value = 0 Then .[d1].Value = 9999
        .[a8:d8].Resize(.[d1].Value).ClearContents
        .[b2:b3].ClearContents
    End With
End Sub

IMO this is the closest you can get. Hopefully this is of some help.

 

[Mousehunter]

Hi Adam, to start with, I sincerely hope you are not affected by the wildfires that your country is currently suffering.

Regarding your issue there are two things that come into play. First of all, the resolution of time. Currently, the smallest unit of time used is milliseconds. This resolution is too low for the purpose you are aiming for. In addition, the time required for both the calculations and the display of the results on the worksheet must also be taken into account. Increasing the resolution of time can be accomplished by calling a few other Win-API functions, wrapped into a separate class with some tailor made methods and properties, which in turn can be used to determine the delay of the code being used for calculations and display purposes.
Despite the foregoing, it is almost impossible to simulate the exact number of beats per minute you intended to. Not only the used (as you said impossible to deactivate) AddIn is responsible for this, also other simultaneously running processes on your computer as well as your own behavior (for example, within Excel changing the selected worksheet range or switching worksheets) will have an effect on the final result.

The code for the separate class module I'm talking about is below. Create a class module (within VBE > menu > Insert > Class module) and paste the code below there. Then rename this module to HiResTimer (within VBE press F4 to open properties window, change (Name) from Class1 to HiResTimer).

This goes in a class module, named HiResTimer:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function QueryFrequency Lib "kernel32" Alias "QueryPerformanceFrequency" (lpFrequency As Currency) As Long
    Private Declare PtrSafe Function QueryCounter Lib "kernel32" Alias "QueryPerformanceCounter" (lpPerformanceCount As Currency) As Long
#Else
    Private Declare Function QueryFrequency Lib "kernel32" Alias "QueryPerformanceFrequency" (lpFrequency As Currency) As Long
    Private Declare Function QueryCounter Lib "kernel32" Alias "QueryPerformanceCounter" (lpPerformanceCount As Currency) As Long
#End If

Private Type TLocals
    Frequency   As Currency
    Overhead    As Currency
    Started     As Currency
    Stopped     As Currency
End Type
Private this As TLocals

Private Sub Class_Initialize()
    Dim Count1 As Currency, Count2 As Currency
    QueryFrequency this.Frequency
    QueryCounter Count1
    QueryCounter Count2
    this.Overhead = Count2 - Count1
End Sub

Public Sub StartTimer()
    QueryCounter this.Started
End Sub

Public Sub StopTimer()
    QueryCounter this.Stopped
End Sub

Public Sub ResetTimer()
    this.Started = 0
    this.Stopped = 0
    Me.StartTimer
End Sub

Public Sub Sleep(ByVal argSeconds As Double)
    Dim SleepTimer As HiResTimer
    Set SleepTimer = New HiResTimer
    With SleepTimer
        .StartTimer
        Do While .Elapsed < argSeconds
        Loop
        .StopTimer
    End With
    Set SleepTimer = Nothing
End Sub

Public Property Get Elapsed() As Double
    Dim Timer As Currency
    With this
        If .Stopped = 0 Then
            QueryCounter Timer
        Else
            Timer = .Stopped
        End If
        If .Frequency > 0 Then
            Elapsed = (Timer - .Started - .Overhead) / .Frequency
        End If
    End With
End Property

The code below is a derivative of your own code and it depends on the HiResTimer class module. Note that all ranges are qualified to the active worksheet.

This goes in a standard module:

Public MinuteCounter As Integer


Sub StartClock_NEW()

    Const TWENTYFOURHOURSINSECONDS  As Long = 86400

    Dim BPM As Long, Rythm As Double, TimeLapse As Double
  
    Dim ws As Worksheet, TimeWatch As HiResTimer
    Dim Bool As Boolean, i As Long

    Set ws = ActiveSheet
    With ws
        If Not IsEmpty(.[j4]) Then

            Let BPM = .[j4]
            Let .[d4] = 0
            If .[d1].Value = 0 Then .[d1].Value = 9999
      
            .[a8:d8].Resize(.[d1].Value).ClearContents
            .[b2:b3].ClearContents
            Let .[d1] = 0
            Let .[b1].Value = "Start"

            Set TimeWatch = New HiResTimer

            ' determine estimated duration of loop
            TimeWatch.StartTimer
            For i = 1 To 5
                Bool = .[b1].Value <> "Stop" Or TimeWatch.Elapsed < .[b4].Value * TWENTYFOURHOURSINSECONDS
                Let .[b3].Value = Now
                Let .[d4] = .[d4] + 0
                Let TimeLapse = .[b4].Value
                VBA.DoEvents
            Next i
            Rythm = (60 / BPM) - (TimeWatch.Elapsed / (i - 1))

            ' go for real ...
            Let .[b2].Value = Now
            TimeWatch.ResetTimer
            Do
                If .[b1].Value = "Stop" Then Exit Do
                Let .[b3].Value = Now
                Let .[d4] = .[d4] + 1
                TimeWatch.Sleep Rythm
                Let TimeLapse = .[b4].Value
                VBA.DoEvents
            Loop Until TimeWatch.Elapsed > TimeLapse * TWENTYFOURHOURSINSECONDS
            Let .[b3].Value = Now
        End If
    End With
End Sub

Sub StopClock_NEW()
    With ActiveSheet
        Let .[b1].Value = "Stop"
        Let .[d1] = MinuteCounter
        If .[d1].Value = 0 Then .[d1].Value = 9999
    End With
End Sub

Sub Reset_Timer_NEW()
    With ActiveSheet
        Let .[b1].Value = "Stop"
        Let .[d4] = 0
        Let .[d1] = MinuteCounter

        If .[d1].Value = 0 Then .[d1].Value = 9999
        .[a8:d8].Resize(.[d1].Value).ClearContents
        .[b2:b3].ClearContents
    End With
End Sub

IMO this is the closest you can get. Hopefully this is of some help.

Thank you so very much for your time and interest.

I logged in, in order to work out a solution for something else but as soon as I find time, I will get back to you. In fact, I had an idea. I could model the discrepancy and correct for it asking for more beats in order to reach my target but I am definitely going to test your code and get back to you.

As for the wildfires, some of them were near the capital and for a couple of days we had to remain inside with windows closed and. Fortunately this time we had no human casualties (except for a firefighter) as several areas were successfully evacuated

 

[GWteB]

You are welcome and thanks for the follow up. I'll keep watching.