Excel Protected sheet with Timer trigger

[laurent_rio]

Hi,

I created excel sheet with timer trigger, so the sheet will protected after timer reach 00:00. The timer is work and excel is protected after timer reach 00:00 but my issue if i put cursor in edit mode, the timer stop moved and my excel become protected before it reach 0 (since actual timer already pass 0)

How to solve this issues, this is my VBA Code

in Module 1

Sub timer()
interval = Now + TimeValue("00:00:01")
If Range("B1").Value = 0 Then Exit Sub
Range("B1") = Range("B1") - TimeValue("00:00:01")
Application.OnTime interval, "timer"
End Sub

in Module 2

Sub Protectsheets()
Sheets("Sheet1").Protect Password:="Password"
End Sub


Then i call this 2 module when excel started/open, in this workbook

Private Sub Workbook_Open()
Application.OnTime Now + TimeValue("00:00:35"), "Protectsheets"
Application.OnTime Now, "timer"
End Sub


Can you help where i make my mistakes ?

Thanks.

Rio

 

[laurent_rio]

I am sorry since English is not my main language. Again sorry for the trouble : )

 

[Jaafar Tribak]

See if this works for you :

Workbook example


In a Standard Module:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
#Else
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

'Change these constants as required.
Private Const ASSESSMENT_SHEET = "Sheet1"
Private Const COUNT_DOWN_CELL_ADDR = "B1"
Private Const SHEET_PASSWORD = "Password"
Private Const COUNT_DOWN_INTERVAL = 1 'Secs
Private Const PROTECT_DELAY = 60 'Secs

Private lCurrentCountDown As Long


Public Sub StartCountDown()
    lCurrentCountDown = 0
    Call UpdateButtons(Sheets(ASSESSMENT_SHEET).Buttons("btnStart"))
    Call SetTimer(Application.hwnd, 0, COUNT_DOWN_INTERVAL * 1000, AddressOf CountDownProc)
End Sub

Public Sub ResetCountDown()
    If lCurrentCountDown Then
        Call KillTimer(Application.hwnd, 0)
        lCurrentCountDown = 0
        Range(COUNT_DOWN_CELL_ADDR).Formula = "=TEXT((0)/(24*60*60),""mm:ss"")"
        Call UpdateButtons(Sheets(ASSESSMENT_SHEET).Buttons("btnReset"))
        Call Sheets(ASSESSMENT_SHEET).Protect(Password:=SHEET_PASSWORD)
    End If
End Sub


Public Sub PauseCountDown()
    If lCurrentCountDown Then
        Call UpdateButtons(Sheets(ASSESSMENT_SHEET).Buttons("btnPause"))
        Call KillTimer(Application.hwnd, 0)
    End If
End Sub

Public Sub ResumeCountDown()
    If lCurrentCountDown Then
        Call KillTimer(Application.hwnd, 0)
        Call UpdateButtons(Sheets(ASSESSMENT_SHEET).Buttons("btnResume"))
        Call SetTimer(Application.hwnd, 0, COUNT_DOWN_INTERVAL * 1000, AddressOf CountDownProc)
    End If
End Sub



Private Sub CountDownProc()

    Const VK_ESC As Long = &H1B
    Const WM_KEYDOWN As Long = &H100

    #If VBA7 Then
        Dim hEdit As LongPtr
    #Else
        Dim hEdit As Long
    #End If

    On Error Resume Next
    
    If lCurrentCountDown = 0 Then
        lCurrentCountDown = PROTECT_DELAY + 1
    End If
    
    Range(COUNT_DOWN_CELL_ADDR).Formula = "=TEXT((" & lCurrentCountDown & "-1)/(24*60*60),""mm:ss"")"
    lCurrentCountDown = lCurrentCountDown - 1
    If lCurrentCountDown = 0 Then GoTo Xit
    
    Exit Sub
    
Xit:
    Call KillTimer(Application.hwnd, 0)
    lCurrentCountDown = 0
    hEdit = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    hEdit = FindWindowEx(hEdit, 0, "EXCEL6", vbNullString)
    If IsWindowVisible(hEdit) Then
        Call Sheets(ASSESSMENT_SHEET).Unprotect(Password:=SHEET_PASSWORD)
        Call PostMessage(Application.hwnd, WM_KEYDOWN, VK_ESC, 0)
        DoEvents
    End If
    Call UpdateButtons(Sheets(ASSESSMENT_SHEET).Buttons("btnReset"))
    Call Sheets(ASSESSMENT_SHEET).Protect(Password:=SHEET_PASSWORD)
    MsgBox "Time Out ! "

End Sub


Private Sub UpdateButtons(ByVal Butn As Button)

    Call Sheets(ASSESSMENT_SHEET).Unprotect(Password:=SHEET_PASSWORD)
    
    With Sheets(ASSESSMENT_SHEET)
        If Butn.Name = .Buttons("btnStart").Name Then
            Butn.Enabled = False
            Butn.Font.ColorIndex = 15
            .Buttons("btnResume").Enabled = False
            .Buttons("btnResume").Font.ColorIndex = 15
            .Buttons("btnPause").Enabled = True
            .Buttons("btnPause").Font.ColorIndex = 1
            .Buttons("btnReset").Enabled = True
            .Buttons("btnReset").Font.ColorIndex = 1
        End If
        
        If Butn.Name = .Buttons("btnPause").Name Then
            Butn.Enabled = False
            Butn.Font.ColorIndex = 15
            .Buttons("btnStart").Enabled = False
            .Buttons("btnStart").Font.ColorIndex = 15
            .Buttons("btnResume").Enabled = True
            .Buttons("btnResume").Font.ColorIndex = 1
            .Buttons("btnReset").Enabled = True
            .Buttons("btnReset").Font.ColorIndex = 1
        End If
        
        If Butn.Name = .Buttons("btnResume").Name Then
            Butn.Enabled = False
            Butn.Font.ColorIndex = 15
            .Buttons("btnStart").Enabled = False
            .Buttons("btnStart").Font.ColorIndex = 15
            .Buttons("btnPause").Enabled = True
            .Buttons("btnPause").Font.ColorIndex = 1
            .Buttons("btnReset").Enabled = True
            .Buttons("btnReset").Font.ColorIndex = 1
        End If
        
        If Butn.Name = .Buttons("btnReset").Name Then
            Butn.Enabled = False
            Butn.Font.ColorIndex = 15
            .Buttons("btnResume").Enabled = False
            .Buttons("btnResume").Font.ColorIndex = 15
            .Buttons("btnPause").Enabled = False
            .Buttons("btnPause").Font.ColorIndex = 15
            .Buttons("btnStart").Enabled = True
            .Buttons("btnStart").Font.ColorIndex = 1
        End If
    End With

End Sub

Private Sub Auto_Close()
    Call ResetCountDown
End Sub

 

[Tom.Jones]

Excellent job Jaafar!

 

[Jaafar Tribak]

Excellent job Jaafar!

Hi Tom.Jones.

I am glad you liked it .. It is indeed nice to see the countdown cell periodically update even when excel is in edit mode.
Thank you for the feedback .

 

[laurent_rio]

Hi Jaafar,

It work well !!! Superb, even though i will need time to understand code behind it !!
Again Thank you very much !!

 

[Jaafar Tribak]

Hi Jaafar,

It work well !!! Superb, even though i will need time to understand code behind it !!
Again Thank you very much !!

Glad you got this working in the end and thanks for the feedback.

 

[laurent_rio]

Hi Jaafar, sorry for revive this thread again. Can i ask you is it possible to create VBA excel to autosubmit/auto send to email when timer is 0 ?

 

[Jaafar Tribak]

Hi Jaafar, sorry for revive this thread again. Can i ask you is it possible to create VBA excel to autosubmit/auto send to email when timer is 0 ?

Hi laurent_rio,

That is a different subject.
I suggest that you start a new thread and ask that question there.