Label on UserForm to show time elapsing With Fractions Of Seconds 1

[patriciaxxx]

I have a VBA UserForm in my Access 2003 database which displays the time elapsed. currently i have only coded it for hh mm ss (hours minutes seconds)

I need the label to display the time as it elapses in the format 00:00:00:00
(hours minutes seconds and fractions of seconds ie 100ths of seconds or milliseconds)

This is my code so far:

rivate Sub UpdateTimerLabel()
    Dim ss As Long
    Dim mm As Long
    Dim hh As Long
    Dim sglTimer As Single
    Const WAV_FILE As String = "C:\WINDOWS\MEDIA\tada.WAV"
    
    sglTimer = Timer
    Do
        ss = Int(Timer - sglTimer)
        If ss = 60 Then mm = mm + 1: ss = 0: sglTimer = Timer
        If mm = 60 Then hh = hh + 1:  mm = 0: sglTimer = Timer
        lblTimer.Caption = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs"
        DoEvents
    Loop Until bExit Or bScore Or bAbort
    If bScore Then
        PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_LOOP Or SND_ASYNC
        If MsgBox("Congratulations " & sUserName & "  !!" & vbCrLf & vbCrLf & _
        "You scored in : " & Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" & vbCrLf & _
        "Do you want to save this score to your scores history  ?", vbQuestion + vbYesNo) = vbYes Then
            Call SaveTheScore(hh, mm, ss)
        End If
        PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_PURGE
    End If
    lblTimer.Caption = ""
    Call EnableControls(True)
    Call DeletePreviousImages
    Set frameSourcePic.Picture = oPic
End Sub

 

[strongm]

Here's one way of doing it (I've simply cut your code down to the bare minimum for the sake of the example):

[blue]Private Sub UpdateTimerLabelExample
    Dim sglTimer As Double
    Dim elapsed As Double
    
    sglTimer = Timer
    Do
        elapsed = Timer - sglTimer
        lblTimer.Caption = TimeSerial(0, 0, elapsed) & ":" & Right("0" & Int(100 * (elapsed - Int(elapsed))), 2)
        [green]' Or
        ' lblTimer.Caption = TimeSerial(0, 0, elapsed) & ":" & Format(100 * (elapsed - Int(elapsed)), "00")
        ' Or to include milliseconds
        ' lblTimer.Caption = TimeSerial(0, 0, elapsed) & ":" & Format(10000 * (elapsed - Int(elapsed)), "00:00")[/green]
        DoEvents
    Loop Until bExit Or bScore Or bAbort
End Sub[/blue]

Note that there probably isn't much point going to milliseconds, since

a) default system timers in Windows only have a resolution of 15.625 milliseconds
b) it seems somewhat unlikely that the puzzle gane this is intended for relies on such tight reflexes that millisecond accuracy would be of any importance

Also note that in reality I'd be more disposed to be updating the timer on a timer event, rather than running in a tight loop as you do. This would involve a small amount of code refactoring, however, so I don't illustrate it here.

 

[combo]

Timer returns Single number, so you already have fractions of seconds, do not cut them with Int function.
Assuming that at sqlTimer counting starts, I would rather calculate passed time as [tt]PassedTime=Timer-sqlTimer[/tt], calculate hours, minutes and seconds (or format it as time), and add formatted fraction (multiply it by 100 or 1000 and format as full number).

combo

 

[patriciaxxx]

Thank you very much for your answers

I tried combo's suggestion and changed my code to
however i now get format 00:00:00 followed by seconds again as decimal ie 00.0000?
how do I format this correctly?

Private Sub UpdateTimerLabel()
    Dim ss As Long
    Dim mm As Long
    Dim hh As Long
    Dim sglTimer As Single
    Const WAV_FILE As String = "C:\WINDOWS\MEDIA\tada.WAV"
    Dim PassedTime
    sglTimer = Timer
    Do
    PassedTime = Timer - sglTimer
        ss = Int(Timer - sglTimer)
        If ss = 60 Then mm = mm + 1: ss = 0: sglTimer = Timer
        If mm = 60 Then hh = hh + 1:  mm = 0: sglTimer = Timer
        lblTimer.Caption = Format(hh, "00") & ":" & Format(mm, "00") & ":" & Format(ss, "00") & ":" & _
            PassedTime
        DoEvents
    Loop Until bExit Or bScore Or bAbort
    If bScore Then
        PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_LOOP Or SND_ASYNC
        If MsgBox("Congratulations " & sUserName & "  !!" & vbCrLf & vbCrLf & _
        "You scored in : " & Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" & vbCrLf & _
        "Do you want to save this score to your scores history  ?", vbQuestion + vbYesNo) = vbYes Then
            Call SaveTheScore(hh, mm, ss)
        End If
        PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_PURGE
    End If
    lblTimer.Caption = ""
    Call EnableControls(True)
    Call DeletePreviousImages
    Set frameSourcePic.Picture = oPic
End Sub

 

[patriciaxxx]

Just tried strongm's suggestion and it produced a flicker free perfect solution.

Thank you both for your time and helpful advice.