Multiple timers on one Sheet - vba

Modified [Halfway there]
Thank you YowE3K, after your comments the code has been modified but yet it is not working as it should be...
Both timers run independently and fine but only when they run separately. At the very moment when I turn both going, they start counting on every 2 seconds instead of one as it should be. I know it is maybe related to this part "Application.OnTime SchdTime + OneSec, "Sheet1.setImmediate" but I don't know how to specify the cell here. Currently they both add one second to Sheet1 when they go together.
Additionally the issue with the timers starting from 00:00:00 after reopening the document stays.
Here is the code - please note that this one is for ToggleButtons:
Dim StopTimer As Boolean
Dim SchdTime As Date
Dim Etime As Date
Dim SchdTime2 As Date
Dim Etime2 As Date
Const OneSec As Date = 1 / 86400#
Private Sub Start_Stop_1_Click()
If Start_Stop_1 = True Then
StopTimer = False
SchdTime = Now()
[K3].Value = Format(Etime, "hh:mm:ss")
Application.OnTime SchdTime + OneSec, "Sheet1.setImmediate"
Else
StopTimer = True
Beep
End If
End Sub
Private Sub Start_Stop_2_Click()
If Start_Stop_2 = True Then
StopTimer = False
SchdTime2 = Now()
[K4].Value = Format(Etime2, "hh:mm:ss")
Application.OnTime SchdTime2 + OneSec, "Sheet1.setImmediate"
Else
StopTimer = True
Beep
End If
End Sub
Sub setImmediate()
If Start_Stop_1 = True Then
[K3].Value = Format(Etime, "hh:mm:ss")
SchdTime = SchdTime + OneSec
Application.OnTime SchdTime, "Sheet1.setImmediate"
Etime = Etime + OneSec
Else: StopTimer = True
'Don't reschedule update
End If
If Start_Stop_2 = True Then
[K4].Value = Format(Etime2, "hh:mm:ss")
SchdTime2 = SchdTime2 + OneSec
Application.OnTime SchdTime2, "Sheet1.setImmediate"
Etime2 = Etime2 + OneSec
Else: StopTimer = True
'Don't reschedule update
End If
End Sub

Related

Countdown timer with time format(00:00:00) in vba access

I am creating Access db which needs auto close the db using timer count down. for example, if I give 5 min then it should start count down displaying this time format 00:04:59
I have found several pieces of tips checking the web, but did not manage to fit the pieces to one working piece.
Below is working perfect. but in output i can see only min and sec 0:00. How to add code for hours as well (format 00:00:00)? I tried to add hours but it is not working
Public Loops As Integer
Private Sub Form_Load()
Me.TimerInterval = 1000
Form_Timer
End Sub
Private Sub Form_Timer()
Static StartTime As Date
Dim SecondsToCount As Integer
SecondsToCount = 15 'Set this variable to the total number of seconds to
count down
If Loops = 0 Then StartTime = Time
Min = (SecondsToCount - DateDiff("s", StartTime, Time)) \ 60
Sec = (SecondsToCount - DateDiff("s", StartTime, Time)) Mod 60
Me.TimeLeft.Caption = "Form will close in " & Min & ":" & Format(Sec,"00")
Loops = Loops + 1
If Me.TimeLeft.Caption = "Form will close in 0:00" Then
DoCmd.Close acForm, Me.Name
End If
End Sub
Use a textbox for display, Timer to get a better resolution, and a TimerInterval of 100 for a closer match.
Complete code-behind module of the form:
Option Compare Database
Option Explicit
Private WatchTime As Date
Private Sub Form_Load()
' Specify count down time.
Const CountDownSeconds As Long = 15
WatchTime = DateAdd("s", CountDownSeconds, Now)
Me!txtCount.Value = WatchTime
Me.TimerInterval = 100
End Sub
Private Sub Form_Timer()
Const SecondsPerDay As Long = 86400
Dim TimeLeft As Date
TimeLeft = CDate(WatchTime - Date - Timer / SecondsPerDay)
Me!txtCount.Value = TimeLeft
If TimeLeft <= 0 Then
Me.TimerInterval = 0
MsgBox "Time ran out!", vbExclamation, "Exit"
DoCmd.Close acForm, Me.Name
End If
End Sub

Converting a timer to show seconds only

I have a timer set as a VB object in a spread sheet. It currently displays as
hh:mm:ss.00. I need it to display as seconds only (no miliseconds or minutes, IE 1:30 should show as 90).
Dim StopTimer As Boolean
Dim Etime As Single
Dim Etime0 As Single
Dim LastEtime As Single
Private Sub CommandButton1_Click()
StopTimer = False
Etime0 = Timer() - LastEtime
Do Until StopTimer
Etime = Int((Timer() - Etime0) * 100) / 100
If Etime > LastEtime Then
LastEtime = Etime
Label1.Caption = Format(Etime / 86400, "hh:mm:ss.") & Format(Etime * 100 Mod 100, "00")
DoEvents
End If
Loop
End Sub
Private Sub CommandButton2_Click()
StopTimer = True
Beep
With New MSForms.DataObject
.SetText Label1.Caption
.PutInClipboard
End With
End Sub
Private Sub CommandButton3_Click()
StopTimer = True
Etime = 0
Etime0 = 0
LastEtime = 0
Label1.Caption = "00"
End Sub
I'm sure I'm simply overlooking something obvious but I'm not overly familiar with timers and formatting.
Please refer this link:
Convert HH:MM:SS string to seconds only in javascript
And try this:
var hms = '02:04:33'; // your input string
var a = hms.split(':'); // split it at the colons
// minutes are worth 60 seconds. Hours are worth 60 minutes.
var seconds = (+a[0]) * 60 * 60 + (+a[1]) * 60 + (+a[2]);
console.log(seconds);
This is probably the easiest and the most comprehensive way, as a minute has 60 seconds and one hour has 3600 seconds.
Thus 1 minute and 30 seconds would be 0*3600 + 1*60 + 30:
Public Sub TestMe()
Dim myTime As Date
myTime = TimeSerial(0, 1, 30)
Debug.Print Hour(myTime) * 3600 + Minute(myTime) * 60 + Second(myTime)
End Sub
It takes 1:30 and it returns 90. You may consider writing a separate function like this one as well:
Public Function TimeToSeconds(Optional hours As Long = 0, _
Optional minutes As Long = 0, _
Optional seconds As Long = 0) As Long
TimeToSeconds = hours * 3600 + minutes * 60 + seconds
End Function

VBA Dateadd Format - Need In Total Minutes

I have a userform in Microsoft Excel that I want to use as a stopwatch. However the format of "hh:mm" does not allow it to go above 23:59 as it goes back to 00:00
Private Sub SpinButton2_SpinUp()
If InsertEvent.TextBox1 = vbNullString Then
InsertEvent.TextBox1 = "00:00"
Else
InsertEvent.TextBox1.Value = Format(DateAdd("n", 1, InsertEvent.TextBox1.Value), "hh:mm")
'InsertEvent.TextBox1.Value = TimeValue("mm:ss")
'InsertEvent.TextBox1.Value = Format(InsertEvent.TextBox1.Value, "hh:mm")
End If
End Sub
Is there anyway to format this so that it can work as a clock of total minutes? Ideally I need it to go to about 125 minutes or so (125:00) but it doesn't matter if it is unlimited.
You can't use the built in Date/Time functions for this as you want a representation that is not a Date/Time.
Assuming you want to read the spinner value into the textbox:
Private Sub SpinButton2_SpinUp()
Dim minutes As Integer: minutes = Val(InsertEvent.SpinButton2.Value)
Dim hh As Integer: hh = minutes \ 60
Dim mm As Integer: mm = minutes - (hh * 60)
InsertEvent.TextBox1.Text = Format$(hh, "00") & ":" & Format$(mm, "00")
End Sub
To use a manually entered value from the textbox as the starting up/down point you need to re-parse "hh:mm" back to minutes, for example in the textbox Exit event:
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If (IsNumeric(TextBox1.Text)) Then
'// entering a number only assumes its minutes
SpinButton2.Value = TextBox1.Text
Exit Sub
End If
Dim hhmm() As String: hhmm = Split(TextBox1.Text, ":")
If (UBound(hhmm) = 1) Then
If (IsNumeric(hhmm(0)) And IsNumeric(hhmm(1))) Then
SpinButton2.Value = (hhmm(0) * 60) + hhmm(1)
Exit Sub
End If
End If
SpinButton2.Value = 0
End Sub
(Should add error checking for overflow/exceeding the spinners .Max property)

Simplify toggle button change BackColor Code VBA

im new in VBA making, so all code below is still working tho but it takes a lot of line of codes. Even it is easier to maintain but if someone can simplify my noob-code to cut some lines and more eye-pleasing?
there are more than 20 toggle buttons in my userform
this is the example of my code, need help for make it simpler
Private Sub tgglC_Result1_Click()
If tgglC_Result1.Value = True Then
tgglC_Result1.BackColor = &HFF00&
tgglNC_Result1.Enabled = False
lblResult1.Caption = Now
lblResult1.Visible = True
Else
tgglC_Result1.BackColor = &H8000000F
tgglNC_Result1.Enabled = True
lblResult1.Visible = False
End If
End Sub
Private Sub tgglC_Result2_Click()
If tgglC_Result2.Value = True Then
tgglC_Result2.BackColor = &HFF00&
tgglNC_Result2.Enabled = False
lblResult2.Caption = Now
lblResult2.Visible = True
Else
tgglC_Result2.BackColor = &H8000000F
tgglNC_Result2.Enabled = True
lblResult2.Visible = False
End If
End Sub
Private Sub tgglC_Result3_Click()
If tgglC_Result3.Value = True Then
tgglC_Result3.BackColor = &HFF00&
tgglNC_Result3.Enabled = False
lblResult3.Caption = Now
lblResult3.Visible = True
Else
tgglC_Result3.BackColor = &H8000000F
tgglNC_Result3.Enabled = True
lblResult3.Visible = False
End If
End Sub
Private Sub tgglC_Result4_Click()
If tgglC_Result4.Value = True Then
tgglC_Result4.BackColor = &HFF00&
tgglNC_Result4.Enabled = False
lblResult4.Caption = Now
lblResult4.Visible = True
Else
tgglC_Result4.BackColor = &H8000000F
tgglNC_Result4.Enabled = True
lblResult4.Visible = False
End If
End Sub
best way should be using a Class
but a more "conventional" way could help you reducing typing burden, too:
define a unique toggle control handling sub
Private Sub tgglC_Result_Click()
Dim NC As Control
With Me
Set NC = .Controls(VBA.Replace(.ActiveControl.Name, "tgglC", "tgglNC")) '<--| set the "counter part" toggle button control of the "Active" control (i.e. the one being currently toggled)
With .ActiveControl
.BackColor = IIf(.Value, &HFF00&, &H8000000F)
NC.Enabled = Not .Value
End With
End With
End Sub
call it from any of your event handler
Private Sub tgglC_Result1_Click()
tgglC_Result_Click
End Sub
Private Sub tgglC_Result2_Click()
tgglC_Result_Click
End Sub
Private Sub tgglC_Result3_Click()
tgglC_Result_Click
End Sub
...
Not really a simplifying solution, but this is what I used when I needed to supply logic to 60+ controls on an Access subform (similar task to yours):
Sub makeCode()
Dim i As Integer
For i = 1 To 4
Debug.Print "Private Sub tgglC_Result" & i & "_Click()"
Debug.Print "tgglC_Result" & i & ".BackColor = &HFF00&"
Debug.Print "tgglNC_Result2.Enabled = False"
Debug.Print "lblResult" & i & ".Caption = Now"
Debug.Print "lblResult" & i & ".Visible = True"
Debug.Print "End Sub"
Debug.Print ""
Next
End Sub
Copy the result from the Immediate window into the code editor. It's easy to change all the subroutines, too: just change the loop body, run it, and replace old code.

Every 5 seconds record the value in 2 cells in another worksheet VBA

Problem:
I have searched extensively for this and cannot seem to get it to work. I have a timer running when the "StartBtn" is pressed:
Dim StopTimer As Boolean
Dim SchdTime As Date
Dim Etime As Date
Dim currentcost As Integer
Const OneSec As Date = 1 / 86400#
Private Sub ResetBtn_Click()
StopTimer = True
Etime = 0
[TextBox21].Value = "00:00:00"
End Sub
Private Sub StartBtn_Click()
StopTimer = False
SchdTime = Now()
[TextBox21].Value = Format(Etime, "hh:mm:ss")
Application.OnTime SchdTime + OneSec, "Sheet1.NextTick"
End Sub
Private Sub StopBtn_Click()
StopTimer = True
Beep
End Sub
Sub NextTick()
If StopTimer Then
'Don't reschedule update
Else
[TextBox21].Value = Format(Etime, "hh:mm:ss")
SchdTime = SchdTime + OneSec
Application.OnTime SchdTime, "Sheet1.NextTick"
Etime = Etime + OneSec
End If
End Sub
Then in another cell (say, C16) I have a manually entered value which is the hourly cost rate. I have a third cell that is calculating total cost by C16*current timer value.
What I want to do is record every 5 seconds after the "StartBtn" is clicked the current time and current calculated cost in another sheet. This is what I have started:
Sub increment()
Dim x As String
Dim n As Integer
Dim Recordnext As Date
n = 0
Record = [TextBox21].Value
Recordnext = [TextBox21].Value + OneSec
Range("B13").Value = Recordnext
Do Until IsEmpty(B4)
If [TextBox21].Value = Recordnext Then ActiveCell.Copy
Application.Goto(ActiveWorkbook.Sheets("Sheet2").Range("A1").Offset(1, 0))
ActiveSheet.Paste
Application.CutCopyMode = False
n = n + 1
Recordnext = [TextBox21].Value + 5 * (OneSec)
Exit Do
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
But it doesnt work. Any help would be appreciated.
I have tried to simplify your timer method down to what is actually needed.
Sheet1 code sheet
Option Explicit
Private Sub ResetBtn_Click()
bRun_Timer = False
'use the following if you want to remove the last time cycle
TextBox21.Value = Format(0, "hh:mm:ss")
End Sub
Private Sub StartBtn_Click()
bRun_Timer = True
dTime_Start = Now
TextBox21.Value = Format(Now - dTime_Start, "hh:mm:ss")
Range("D16").ClearContents
Call next_Increment
End Sub
Module1 code sheet
Option Explicit
Public bRun_Timer As Boolean
Public Const iSecs As Integer = 3 'three seconds
Public dTime_Start As Date
Sub next_Increment()
With Worksheets("Sheet1")
.TextBox21.Value = Format(Now - dTime_Start, "hh:mm:ss")
.Range("D16") = Sheet1.Range("C16") / 3600 * _
Second(TimeValue(Sheet1.TextBox21.Value)) '# of secs × rate/sec
Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Resize(1, 2).Offset(1, 0) = _
Array(.TextBox21.Value, .Range("D16").Value)
End With
If bRun_Timer Then _
Application.OnTime Now + TimeSerial(0, 0, iSecs), "next_Increment"
End Sub
Note that the operation of transferring the data to Sheet2 is a direct value transfer¹ with no .GoTo, ActiveCell or Select.
It was not entirely clear to me what you were trying to do with the value transfer. I have stacked them one after another on Sheet1.
        
You would benefit by adding Option Explicit² to the top of all your code sheets. This requires variable declaration and if you misplace a public variable, you will quickly know.
¹ See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
² Setting Require Variable Declaration within the VBE's Tools ► Options ► Editor property page will put the Option Explicit statement at the top of each newly created code sheet. This will avoid silly coding mistakes like misspellings as well as influencing you to use the correct variable type in the variable declaration. Variables created on-the-fly without declaration are all of the variant/object type. Using Option Explicit is widely considered 'best practice'.