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,

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-OPSNSW Site WarehouseSpare - Condell ParkNew Spare Stock Order-Matic 2.3Spare_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

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

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

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,

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

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,

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

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,

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

You're welcome

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

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,

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 [email protected]. 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