January 30, 2020
Hi There,
Below is a internal time in VBA where I will give people time in a Openworkbook where it will activate and if its gone past a certain point it will close and save. ALSO I also created a command button to go another workbook, where I want the SUB Time() to STOP running in VBA. Reason being is the database when the command button is opening another workbook, in the background its saving the database that its already opened and then close it - simple.
The problem is the Sub Time() - is still going on in the background as its in a Loop and I cant access the next database or open when I select the command button.
The workbook is attached but I think it needs checking. You need to go F8 to view the module of spare stock .
Sub Time()
Dim Start, Finish, TotalTime, TotalTimeInMinutes, TimeInMinutes
'StartTimer
Application.DisplayAlerts = True
TimeInMinutes = Sheet1.Range("A1").Value 'Timer is set for 180 minutes; change as needed.
If TimeInMinutes > 5 Then
TotalTimeInMinutes = (TimeInMinutes * 60) - (5 * 60)
Start = Timer
Do While Timer < Start + TotalTimeInMinutes
DoEvents
Loop
Finish = Timer
TotalTime = Finish - Start
Application.DisplayAlerts = False
MsgBox "This file has been open for " & TotalTime / 60 & " minutes. You have 5 minutes to save before Excel closes."
End If
Start = Timer
Do While Timer < Start + (5 * 60)
DoEvents
Loop
Finish = Timer
TotalTime = Finish - Start
'Application.DisplayAlerts = False
'MsgBox "Excel will now close."
ActiveWorkbook.Save
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Sub
********I also have a stopwatch in my database and that works perfectly. But After I click the command button the Sub Time() has to stop
Private Sub CommandButton4_Click()
' (NEED TO INPUT A CODE TO STOP THE SUB TIME()???)
Application.OnTime EarliestTime:= _
Now + TimeValue("00:00:10"), Procedure:="EndPleaseWait"
PleaseWait
Application.ScreenUpdating = True
Unload frmMenu
Unload Me
Unprotect_All
stop_timer
Workbooks.Open FileName:= _
"H:\PROJECT-OPS\NSW Site Warehouse\Spare - Condell Park\New Spare Stock Order-Matic 2.3\Spare_Parts_Order_Matic_2.3.xlsm"
Application.WindowState = xlMinimized
Workbooks("Bucketty_Order-Matic_2.1.xlsm").Close SaveChanges:=True
End Sub
February 20, 2020
Hello,
in the following code, I inserted the count down with stop, pause and continue, I hope I can help
I performed the procedures with:
_ 1 module
_ 1 userform with: 1 label; 1 textbox; 4 command buttons
Place the following lines in a module
Option Explicit
Public Const sCount As Long = 5400 ' secs
Public cTime As Double
Public pauseCount As Boolean
Public Sub StarTimer() ' RUN COUNT DOWN
If cTime > 1 Then
If pauseCount = False Then
cTime = cTime
Else
cTime = cTime - 1
End If
UserForm1.Label9.Caption = Format(TimeSerial(0, 0, cTime), "hh:mm:ss")
UserForm1.TextBox1.Text = Format(TimeSerial(0, 0, cTime), "hh:mm:ss")
Application.OnTime Now + TimeSerial(0, 0, 1), "StarTimer"
End If
End Sub
Public Sub stoptime() ' STOP COUNT DOWN
cTime = 0
End Sub
Place the following lines in a Userform module
Option Explicit
Private Sub CommandButton1_Click()
' RUN COUNT DOWN
cTime = sCount
Call StarTimer
pauseCount = True
End Sub
Private Sub CommandButton2_Click()
pauseCount = False
Call stoptime ' STOP COUNTDOWN
End Sub
Private Sub CommandButton3_Click()
pauseCount = True ' CONTINUE
End Sub
Private Sub CommandButton4_Click()
pauseCount = False ' TAKE A BREAK
End Sub
Private Sub TextBox1_Change()
Dim hTime As Variant, mTime As Variant, sTime As Variant, dtime As Variant
Dim startTime As Date, endTime As Date
Dim tHrs As Long, tMinutes As Long, tSeconds As Long
tSeconds = sCount
tHrs = Int(tSeconds / 3600)
tMinutes = (Int(tSeconds / 60)) - (tHrs * 60)
tSeconds = Int(tSeconds Mod 60)
If Me.TextBox1.Text = "00:05:00" Then
startTime = tHrs & ":" & tMinutes & ":" & tSeconds ' at the start
endTime = Me.TextBox1.Text ' at the end
hTime = DateDiff("h", endTime, startTime)
mTime = DateDiff("m", endTime, startTime)
sTime = DateDiff("s", endTime, startTime)
dtime = hTime & ":" & mTime & ":" & sTime
' MsgBox "This file has been open for " & Format(dtime, "hh:mm:ss") & ". You have 5 minutes to save before Excel closes."
MsgBox "This file has been open for " & hTime & " hours, " & mTime & " minutes, " & sTime & " seconds" & ". You have 5 minutes to save before Excel closes."
End If
End Sub
(I attached the sample file)
Miguel,
January 30, 2020
Thanks Miguel,
So this means I need to redesign my time allocation?
Also does this mean the code in Userform 1 below, Do I need to put after End if
'MsgBox "This file has been open for " & Format(dtime, "hh:mm:ss") & ". You have 5 minutes to save before Excel closes."
MsgBox "This file has been open for " & hTime & " hours, " & mTime & " minutes, " & sTime & " seconds" & ". You have 5 minutes to save before Excel closes."
End If
****
ActiveWorkbook.Save
Application.DisplayAlerts = True
ActiveWorkbook.Close
WILL THIS SAVE AND CLOSE AFTER THE TIME HAS BEEN ALLOTED???
And do I need to add Call stoptime so that when a person click the command button that the time will stop
Application.OnTime EarliestTime:= _
Now + TimeValue("00:00:10"), Procedure:="EndPleaseWait"
PleaseWait
Application.ScreenUpdating = True
Unload frmMenu
Unload Me
Unprotect_All
**************
Call stoptime ' STOP COUNTDOWN
**************
Workbooks.Open FileName:= _
"H:\PROJECT-OPS\NSW Site Warehouse\Spare - Condell Park\New Spare Stock Order-Matic 2.3\Spare_Parts_Order_Matic_2.3.xlsm"
Application.WindowState = xlMinimized
Workbooks("Bucketty_Order-Matic_2.1.xlsm").Close SaveChanges:=True
ALSO,
In the code
Option Explicit
' Use this for time allocation
Public Const sCount As Long = 600 ' secs
LASTLY,
Does the code below, can I change to a value thats been arranged for a different user in cell
Option Explicit
' Use this for time allocation
Public Const sCount As Long = 600 ' secs
Public Const sCount As Long = Sheet1.Range("A1").Value
This is quite extensive and is very good because I have a cell as timer but you have a useform which I could have as a floating timer.
If you can confirm my reply that would be great.
Thanks Miguel
Steve
February 20, 2020
Hello,
Yes, you can add the rest of your code ... I signaled where to insert.
you can use the stop, pause and continue procedure in any macro you write without needing the command buttons
I prefer to have the counter start time on the module and not on the cell.
I placed 4 command buttons on the excel sheet (run, stop, pause & continue), so you can choose whether to have a userform or not.
Examples of changes: in the excel sheet module
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal target As Range)
' LOCK CELLS
If target.Column = 1 Then
If target.Row = 1 Then
Beep
Cells(target.Row, target.Column).Offset(0, 1).Select
MsgBox Cells(target.Row, target.Column).Address & " Blocked cell, no change allowed!", vbInformation, "Autorization denied!"
End If
End If
End Sub
Private Sub Worksheet_change(ByVal target As Range)
' TIME CHANGE
Dim xRange As Range
Set xRange = Range("A1")
If Not Application.Intersect(xRange, Range(target.Address)) Is Nothing Then
If xRange.Text = "00:05:00" Then MsgBox "You have 5 minutes to save before Excel closes.", vbInformation, "Warning!"
'----------------------------------------
' YOU CAN ADD YOUR CODE HERE
' ...
' YOU CAN ADD HERE PROCEDURE TO STOP OR PAUSE COUNT DOWN
' YOU CAN ADD YOUR CODE HERE
' ...
' IF YOU HAVE INSERTED PROCEDURE TO PAUSE, NOW YOU CAN ADD THE PROCEDURE TO CONTINUE
'----------------------------------------
End If
End If
End Sub
Examples of changes: in module
Option Explicit
Public Const sCount As Long = 5400 ' seconds 'I PREFER TO HAVE TIME HERE, AND IN SECONDS
Public cTime As Double
Public runCount As Boolean
Public Sub StarTimer() ' RUN COUNT DOWN
Dim getTime As String
If cTime > 1 Then
If runCount = False Then
cTime = cTime
Else
cTime = cTime - 1
End If
' if you don't want to userform, remove the next two lines
UserForm1.Label9.Caption = Format(TimeSerial(0, 0, cTime), "hh:mm:ss")
UserForm1.TextBox1.Text = Format(TimeSerial(0, 0, cTime), "hh:mm:ss")
' for excel cell to have count down ( if you want)
Application.ThisWorkbook.Worksheets("Folha1").Range("A1").Value = Format(TimeSerial(0, 0, cTime), "hh:mm:ss")
getTime = Format(TimeSerial(0, 0, cTime), "hh:mm:ss")
Application.OnTime Now + TimeSerial(0, 0, 1), "StarTimer"
If getTime = "00:05:00" Then MsgBox "You have 5 minutes to save before Excel closes."
'----------------------------------------
' YOU CAN ADD YOUR CODE HERE
' ...
' YOU CAN ADD HERE PROCEDURE TO STOP OR PAUSE COUNT DOWN
' YOU CAN ADD YOUR CODE HERE
' ...
' IF YOU HAVE INSERTED PROCEDURE TO PAUSE, NOW YOU CAN ADD THE PROCEDURE TO CONTINUE
'----------------------------------------
End If
End Sub
Public Sub stoptime() ' STOP COUNT DOWN & (SHEET COMMANDBUTTON)
cTime = 0
End Sub
Public Sub runCountDown() ' SHEET COMMANDBUTTON
' RUN COUNT DOWN
cTime = sCount
Call StarTimer
runCount = True
End Sub
Public Sub ContinueRun() ' SHEET COMMANDBUTTON
runCount = True ' CONTINUE
End Sub
Public Sub PauseRun() ' SHEET COMMANDBUTTON
runCount = False ' TAKE A BREAK
End Sub
Miguel,
I attached an example with these changes
January 30, 2020
Thanks Miguel,
This works perfectly!
There is one thing. Because I made UserName and passcode login....Who-ever is logged on there is a time allocation table to which the below code refers too on how long a user can be on my database....code as follows (Referred to my previous inquiry)
TimeInMinutes = Sheet19.Range("BB8").Value
You have indicated below or in your previous reply
Option Explicit
Public Const sCount As Long = 60 ' seconds
Public cTime As Double
Public runCount As Boolean
Is there a way in the option so that it refers to time allocation table in my Sheet TAB
Sheet19.Range("BB8").Value
I have tried Public Const sCount As Long = Sheet19.Range("BB8").Value BUT debugs on Value
Thanks for your help on this!
Steve
February 20, 2020
Hello,
you can do it in many ways...
Example 1: to refer to the value in a cell
( Changes in module )
Option Explicit
'Public Const sCount As Long = 5400 ' seconds
Public sCount As Long
Public cTime As Double
Public runCount As Boolean
...
( Changes in Userform module ) ... for sheet module is the same
Private Sub CommandButton1_Click()
If IsNumeric(Application.ThisWorkbook.Worksheets("Folha1").Range("A2").Value) = False Then
MsgBox "The value is not numeric!", vbCritical, "Warning"
Exit Sub
End If
Dim x As Integer
x = Application.ThisWorkbook.Worksheets("Folha1").Range("A2").Value
sCount = x
' RUN COUNT DOWN
cTime = sCount
Call StarTimer
runCount = True
End Sub
------------------------------------------------------------------------------------------------------
Example 2:
Or you can, if you have multiple users, and each one has a reference as to whether he is a user or an administrator:
( Changes in module )
Public Const sCount As Long = 5400 ' seconds ' for administrator
Public Const sCount_2 As Long = 1500 ' seconds ' for users
...
Public Sub StarTimer() ' RUN COUNT DOWN
' and here you can use the select case ( case user or case administrator ...)
( Changes in Userform module ) ... for sheet module is the same
Private Sub CommandButton1_Click()
' and here you can use the select case ( case user or case administrator ...)
Miguel,
January 30, 2020
Thanks Miguel,
I have added
Option Explicit
'Public Const sCount As Long = 60 ' seconds
Public Const sCount As Long = Folha1.Range("A2").Value
Public cTime As Double
Public runCount As Boolean
But its compile error :Constaint expression required???
can you shed something that I missed I do believe it needs a = ??? after As Long...Unless im missing something here
Steve
February 20, 2020
Hello,
as I explained in my previous reply, writing this way is wrong :
Public Const sCount As Long = Folha1.Range("A2").Value you have to write as follows ------------------------------------------------------------------------------------------------------ in code module ( I highlighted in blue the altered parts for that purpose )
Option Explicit
Public sCount As Long
Public cTime As Double
Public runCount As Boolean
Public Sub StarTimer() ' RUN COUNT DOWN
Dim getTime As String
If cTime > 1 Then
If runCount = False Then
cTime = cTime
Else
cTime = cTime - 1
End If
' next 2 lines for userform
UserForm1.Label9.Caption = Format(TimeSerial(0, 0, cTime), "hh:mm:ss")
UserForm1.TextBox1.Text = Format(TimeSerial(0, 0, cTime), "hh:mm:ss")
' next line for sheet cell
Application.ThisWorkbook.Worksheets("Folha1").Range("A1").Value = Format(TimeSerial(0, 0, cTime), "hh:mm:ss")
getTime = Format(TimeSerial(0, 0, cTime), "hh:mm:ss")
Application.OnTime Now + TimeSerial(0, 0, 1), "StarTimer"
If getTime = "00:05:00" Then MsgBox "You have 5 minutes to save before Excel closes."
'----------------------------------------
' YOU CAN ADD YOUR CODE HERE
'----------------------------------------
End If
End Sub
Public Sub stoptime() ' STOP COUNT DOWN & (SHEET COMMANDBUTTON)
cTime = 0
End Sub
Public Sub runCountDown() ' SHEET COMMANDBUTTON
If IsNumeric(Application.ThisWorkbook.Worksheets("Folha1").Range("A2").Value) = False Then
MsgBox "The value in A1 is not numeric", vbCritical, "Warning"
Exit Sub
ElseIf Application.ThisWorkbook.Worksheets("Folha1").Range("A2").Text = "" Then
MsgBox "No value in cell!", vbCritical, "Warning"
Exit Sub
End If
Dim x As Integer
x = Application.ThisWorkbook.Worksheets("Folha1").Range("A2").Value
sCount = x
' RUN COUNT DOWN
cTime = sCount
Call StarTimer
runCount = True
End Sub
Public Sub ContinueRun() ' SHEET COMMANDBUTTON
runCount = True ' CONTINUE
End Sub
Public Sub PauseRun() ' SHEET COMMANDBUTTON
runCount = False ' TAKE A BREAK
End Sub
example for userform module ( I highlighted in blue the altered parts for that purpose )
Option Explicit
Private Sub CommandButton1_Click()
If IsNumeric(Application.ThisWorkbook.Worksheets("Folha1").Range("A2").Value) = False Then
MsgBox "The value in A1 is not numeric", vbCritical, "Warning"
Exit Sub
ElseIf Application.ThisWorkbook.Worksheets("Folha1").Range("A2").Text = "" Then
MsgBox "No value in cell!", vbCritical, "Warning"
Exit Sub
End If
Dim x As Integer
x = Application.ThisWorkbook.Worksheets("Folha1").Range("A2").Value
sCount = x
' RUN COUNT DOWN
cTime = sCount
Call StarTimer
runCount = True
End Sub
Private Sub CommandButton2_Click()
runCount = False
Call stoptime ' STOP COUNTDOWN
End Sub
Private Sub CommandButton3_Click()
runCount = True ' CONTINUE
End Sub
Private Sub CommandButton4_Click()
runCount = False ' TAKE A BREAK
End Sub
Private Sub TextBox1_Change()
Dim hTime As Variant, mTime As Variant, sTime As Variant, dtime As Variant
Dim startTime As Date, endTime As Date
Dim tHrs As Long, tMinutes As Long, tSeconds As Long
tSeconds = sCount
tHrs = Int(tSeconds / 3600)
tMinutes = (Int(tSeconds / 60)) - (tHrs * 60)
tSeconds = Int(tSeconds Mod 60)
If Me.TextBox1.Text = "00:05:00" Then
startTime = tHrs & ":" & tMinutes & ":" & tSeconds ' at the start
endTime = Me.TextBox1.Text ' at the end
hTime = DateDiff("h", endTime, startTime)
mTime = DateDiff("m", endTime, startTime)
sTime = DateDiff("s", endTime, startTime)
dtime = hTime & ":" & mTime & ":" & sTime
'MsgBox "This file has been open for " & Format(dtime, "hh:mm:ss") & ". You have 5 minutes to save before Excel closes."
MsgBox "This file has been open for " & hTime & " hours, " & mTime & " minutes, " & sTime & " seconds" & ". You have 5 minutes to save before Excel closes."
End If
End Sub
I attached a workbook with an example of these changes
miguel,
January 30, 2020
Hi Miguel,
Yes now I understand!
Its the Sheet module that I had to use
Public Sub runCountDown() ' SHEET COMMANDBUTTON
If IsNumeric(Application.ThisWorkbook.Worksheets("Folha1").Range("A2").Value) = False Then...so on.
All is working and is functioning, HOWEVER, in my database I have a log out and save button and even though the time stops saves and close....the workbook reopens !!!!!....I tried different combinations from the the below code. But still it reopens.
Public Sub LogoutSaveClose()
cTime = 0
Application.DisplayAlerts = False
ThisWorkbook.Close SaveChanges:=True
'Workbooks("CountDown-1-2.xlsm").Close SaveChanges:=False
'Application.DisplayAlerts = False
'Application.ThisWorkbook.Close SaveChanges:=True
'ActiveWorkbook.Close SaveChanges:=True
End Sub
I also had in my database (As a fail safe) Before close workbook Code is below. Even still the workbook reopens
Private Sub Workbook_BeforeClose(Cancel As Boolean)
stoptime
'Application.DisplayAlerts = FalseActiveWorkbook.Close SaveChanges:=True
End Sub
I do believe this is the tail end of the reconstruction of my time allocation in my database
Thanks for your patience
Steve
February 20, 2020
Hello,
I made some changes and it works perfectly for me, then tell me if it worked ... I apologize for the lack of time to solve this code the first time, and for some errors I have...
changes in code module
Public Function PauseInEvent(ByVal Delay As Double) ' WAIT A MOMENT WITH LOOP
Dim TheEndOfTime As Double
TheEndOfTime = Timer + Delay
Do While Timer < TheEndOfTime
DoEvents
Loop
End Function
Public Sub LogoutSaveClose()
runCount = False
Call stoptime ' STOP COUNTDOWN
PauseInEvent (0.1) ' (MACRO) to make a pause
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.ThisWorkbook.Save
PauseInEvent (0.1) ' (MACRO) to make a pause
Application.ThisWorkbook.Close
'it's working for me, but if you don't need to have the excel application open, activate the next line of code
'Application.Quit
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I attached a workbook with an example of these changes
Miguel,
January 30, 2020
Thanks for your help Miguel,
No need to apologies.
This works perfectly and I like the code pauseinevent putting to sleep the macro which ordinary shouldve been implemented in the first database is a gem! And im quite amazed.
So I've learnt a lot from your coding and hopfully when i do a new database I can add a few more features in the time allocation table.
Much appreciate your hard work and understanding.
Thanks
Steve
January 30, 2020
Sorry to disturb you Miguel!,
All is working well!.However since ive been busy at work and heading back to my database I have another problem.
Because in my Open Workbook case with various functions (I provide you the code below) ...log in...splash screens and the like...when I input the runCountDown into the Workbook_Open it doesnt seem to countdown???....Ive tried to take away the Private Sub and do a plain but still nothing.
Is there anything that I missed to make the countdown start uopn opening workbook
Private Sub Workbook_Open()
'Auto_Open detail functions
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
'Should be true
ActiveWindow.DisplayWorkbookTabs = False
Application.DisplayStatusBar = False
Application.DisplayFormulaBar = False
' Making the Ribbon visible is true
Application.DisplayFullScreen = False
ActiveWindow.DisplayHeadings = False
ActiveWindow.DisplayWorkbookTabs = Not ActiveWindow.DisplayWorkbookTabs
Application.ScreenUpdating = False
'Protection modes
Protect_Code_Exclude
GetSheets
VisibleFalse
Showme
'My Spalsh Screen
Application.ScreenUpdating = True
Application.OnTime EarliestTime:= _
Now + TimeValue("00:00:07"), Procedure:="EndSplash"
Showme2
Sheet1.Range("A2").Select
'Time Allocation
runCountDown
End
Thanks for your help
Steve
February 20, 2020
Hello,
Without having access to all the procedures (Workbook in: Private Sub Workbook_Open() ) it is difficult to say what is causing the error.
I added the code that wrote to my workbook, and since I don't have the following macros:
'Protection modes
Protect_Code_Exclude
GetSheets
VisibleFalse
Showme
&
Application.OnTime EarliestTime:= _
Now + TimeValue("00:00:07"), Procedure:="EndSplash"
Showme2
I removed them, and the timer started without any problems, try adding a pause in the procedures, you can adjust the pause time example: ' ...
'My Spalsh Screen
Application.ScreenUpdating = True
Application.OnTime EarliestTime:= _
Now + TimeValue("00:00:07"), Procedure:="EndSplash"
PauseInEvent (0.01) ' (MACRO) to make a pause ( you can adjust the time )
Showme2
PauseInEvent (0.1) ' (MACRO) to make a pause ( you can adjust the time )
' ...
tell me if it worked, if not, I will need to know how the other macro works,
Miguel,
January 30, 2020
Hi Miguel,
Sorry mate, I found out what is happening here.
In my database, I have protection modes in place to prevent people from doing anything on my interface (main screen/TAB). Hence, in the open workbook code; Protect_Code_Exclude.
when the database opens (1st time), it does the login parameters ect...then starts counting down. When I log out and save, it does what its told.
When I re-boot, the time had paused after log out and save say 2:30 but no login parameters and no countdown or restart countdown.
Reason being, the Interface has password protection in cells and is locked. Therefore, when the code below
Application.ThisWorkbook.Worksheets("Interface").Range("A1").Value...ect It cant read or implement the time as its protected.
Because my database is large, I cannot compress it enough to send it through. My email address is stevenbehr1@gmail.com. If you send your personal address I send my database in to you so you can look at it.
My only other solution, is to use the userform countdown and to float it when DBase starts, might be more practical???? as it doesn't need protection.
I have tried other codes like my Unprotect_all in Logoutsaveclose then reopen, and because I put runCountDown in the begining of my OpenWorkbook the runCountDown still cant work...PROTECTED!. I can however, Unprotect the workbook then hit run count down button and will restart the clock.
Let me know if you want the database and I can send it to you.
Thanks
Steve
February 20, 2020
Hello,
To avoid this type of conflict, I mentioned that it was preferable that time be written in a macro instead of in a range, and the macro to start counting can be inserted in any macro, which makes it easier to restart counting whenever if you want.
I have time counters on several VBProjects, with ranges and sheets protected by passwords, as well as password protected VBA, without conflicts... In my opinion, to help (extra forum), we will have to ask permission from the forum Administrators
If authorized, I will try to help... (only then, i send email to you) Regards, Miguel,
October 5, 2010
Hi Steve,
You can share a file on OneDrive without needing to email anyone.
Right click the file -> Share
make sure at the top of the pop-up it says 'Anyone with link can edit'
Click on copy link to create the link
Then copy the link it generates and that is what someone else uses to access your file. You can paste the link in here.
But, I have forwarded the link you emailed me to Miguel.
Phil
January 30, 2020
OK then Phil,
Thanks for that.
Just in case
Onedrive
Spare_Parts_Order_Matic_2.3.xlsm
Dropbox
https://www.dropbox.com/scl/fi.....64fsz1h8xe
See how I go!
Steve
1 Guest(s)