PDA

View Full Version : Timer + Stop Watch



Svmaxcel
08-24-2017, 12:39 AM
I have a code to close workbook automatically after 30 min so that, if others has kept the file open others won't be able to use it.
Below is the code.
Module 1


Option Explicit

Dim DownTime As Date

Sub SetTimer()
DownTime = Now + TimeValue("00:30:00") ''<--- change time to close here
Application.OnTime EarliestTime:=DownTime, Procedure:="ShutDown", Schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=DownTime, _
Procedure:="ShutDown", Schedule:=False
End Sub
Sub ShutDown()

Application.DisplayAlerts = False
With ThisWorkbook
.Saved = True
.Close
End With

End Sub


Added below code in Thisworksheet.


Option Explicit

Private Sub Workbook_Open()
Call SetTimer
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call StopTimer
Application.DisplayAlerts = False
ThisWorkbook.Saved = True
Application.Visible = False
Application.Quit
End Sub

I want that all changes should be saved in a file,



To track changes in the workbook, paste this code into ThisWorkbook module :

Option Explicit
Dim vOldVal 'Must be at top of module

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim strUserName As String
Dim xFormula As Boolean
Dim xDate As Boolean
Dim xHead As Range
Dim xTitle As Range
Dim n As Integer

Set xHead = Sheets("Track_Changes").Range("B3:H3")
strUserName = Application.UserName

On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

If IsEmpty(vOldVal) Then vOldVal = "[empty cell]"
xFormula = Target.HasFormula
xDate = IsDate(Target)

With Sheets("Track_Changes")
.Unprotect Password:="Password"

If .Range("B2") = vbNullString Then
xHead = Array("DATE OF CHANGE", "TIME OF CHANGE", "SHEET NAME", "CELL CHANGED", "CHANGE BY", "OLD VALUE", "NEW VALUE")
Sheets("Track_Changes").Columns(1).ColumnWidth = 3

.Range("B1").Value = "Track Changes"
.Range("B1").Font.Size = 18

With xHead
.Interior.Color = RGB(30, 139, 195)
.Font.Color = vbWhite
.Font.Bold = True
End With

With xHead.Borders(xlInsideVertical)
.Color = vbWhite
.Weight = xlMedium
End With
End If


With .Cells(.Rows.Count, 2).End(xlUp)(2, 1)
.Borders(xlInsideVertical).Color = RGB(255, 191, 191)
.Borders(xlInsideVertical).Weight = xlMedium

.Value = Date
.Offset(0, 1) = Format(Now, "hh:mm:ss")
.Offset(0, 2) = Target.Parent.Name
.Offset(0, 3) = Target.Address
.Offset(0, 4) = strUserName
.Offset(0, 5) = vOldVal

With .Offset(0, 6)
If xFormula = True Then
.ClearComments
.AddComment.Text Text:="Cell is bold as value contains a formula"
End If
If xDate = True Then
.NumberFormat = "dd/mm/yyyy"
End If
.Value = Target
.Font.Bold = xFormula
If IsEmpty(Target) Then .Value = "[empty cell]"
End With

End With

.Cells.Columns.AutoFit
.Cells.Columns.HorizontalAlignment = xlLeft

n = Sheets("Track_Changes").Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count - 1
With Sheets("Track_Changes").Range("B4:H" & n + 2)
.Borders(xlInsideHorizontal).Color = RGB(30, 139, 195)
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).Color = RGB(200, 200, 200)
.Borders(xlInsideVertical).Weight = xlThin
End With
.Protect Password:="Password"
End With
vOldVal = vbNullString

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

On Error GoTo 0

End Sub



Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

On Error Resume Next
If Selection.Cells.Count > 1 Then Exit Sub 'Avoid runtime error 7
vOldVal = Target

End Sub



My issue is that a user will not come to know when he had opened the file and when it will close.
So I want a timer displaying the minutes left, a normal pop up will also do, to alert the user.
Also if possible, can we add a extend option to extend the period.

offthelip
08-24-2017, 02:05 AM
try this:


Sub SetTimer()
DownTime = Now + TimeValue("00:05:00") ''<--- change time to close here
Application.OnTime EarliestTime:=DownTime, Procedure:="ShutDown", Schedule:=True
End Sub




Sub Setwarning()
DownTime = Now + TimeValue("00:25:00") ''<--- change time to close here
Application.OnTime EarliestTime:=DownTime, Procedure:="Warning", Schedule:=True
End Sub
Sub Setwarning5()
DownTime = Now + TimeValue("00:05:00") ''<--- change time to close here
Application.OnTime EarliestTime:=DownTime, Procedure:="Warning", Schedule:=True
End Sub


Sub warning()
ext = MsgBox("You only have 5 minutes left to use this file, do you want to extend by 5 minutes?", vbYesNo)
If ext = vbYes Then
Call Setwarning5
Else
Call SetTimer
End If


End Sub


Private Sub Workbook_Open()
Call Setwarning
End Sub




note: not tested

Svmaxcel
08-24-2017, 04:41 AM
Hi
Where should input the code.
I mean is it in Thisworksheet, new modules?

offthelip
08-24-2017, 05:46 AM
The private sub workbook_open has to go in "This Workbook" which presumably is where you had it anyway, I just changed the subroutine it was calling

the setwarning and setwarning5 subroutines can go where you had the setTimer routine which I presume was in module 1, since you wrote module 1 at the top. but it isn't critical you can put them more or less anywhere.