Assign Expiry Date(Time-Lock) to Excel Workbook

[nabeelahmed]

Dear Friends,

Can somebody help me for subject topic, How can we add expiry date (Time-Lock) to a Excel workbook so that after that date Workbook gets lock and required password to re-validate/Unlock ???

Regards,

 

[QCLAN]

DOn't understand why it isn't working in your case. It works fine on my test.

However, in the amended code below I force the hidden worksheet to be unlocked.

Replace the sub in your code with this one

Sub ResetLockDate()
'Allows authorised user to change the lock date
    Dim vP
    Dim dDt As Date
    Dim sMsg As String
 
    vP = InputBox(prompt:="Please enter password to change the lockdate for this workbook", _
                Title:="Password required")
    If vP = sPW Then
        dDt = GetDate
        If dDt <= Date And Date > Range(sLDName) Then
            MsgBox "Date provided does not make sense: the workbook is already locked. No action taken."
        Else
            Sheets(sHDName).Unprotect sPW
            Range(sLDName) = dDt
            If Range(sWBLName) Then
                UnlockSheets sPW
                Range(sWBLName) = False
                sMsg = "All worksheets have been unlocked. " & vbCrLf
            End If
            MsgBox sMsg & "Lock date set to: " & Format(dDt, "short date")
        End If
    Else
        MsgBox "Incorrect or no password given. No action taken"
    End If
End Sub

Thanks sijpie, but it is now giving me the following error when I run the 'ResetLockDate" (see images)

 

[sijpie]

Weird, weird.
When it shows the VBA with the line in yellow, press the F8 key to step through the code to see where it hangs up with an error message. Let me know the message and at what line it happened.

 

[QCLAN]

Weird, weird.
When it shows the VBA with the line in yellow, press the F8 key to step through the code to see where it hangs up with an error message. Let me know the message and at what line it happened.

It seems to highlight the following code:

vP = InputBox(prompt:="Please enter password to change the lockdate for this workbook", _

                Title:="Password required")

[Code=/VBA]

 

[raji123]

This code into the normal module:

Option Explicit

Public Const sHDName = "ProtectSupport", sLDName = "LockDate", sWBLName = "WBLocked"
Public Const sPW = "MyPW"      '<<<<< Change to suit your password

Dim bReset As Boolean

Sub FirstTimeSetup()
'Macro call by Workbook_Open to set and store the lock date
'This is stored in a sheet which will be hidden
    Dim wsWS As Worksheet
   
    Application.ScreenUpdating = False
    On Error Resume Next
    Set wsWS = Sheets(sHDName)
    On Error GoTo 0
    If wsWS Is Nothing Then      'sheet does not exist, create
        With ThisWorkbook
            Set wsWS = .Sheets.Add(after:=.Sheets(.Sheets.Count))
            wsWS.Name = sHDName
            .Names.Add Name:=sLDName, RefersTo:=wsWS.Range("A2")
            .Names.Add Name:=sWBLName, RefersTo:=wsWS.Range("A5")
        End With
        With Range(sLDName)
            .Offset(-1, 0) = sLDName
            .Value = GetDate
            .Offset(2, 0) = sWBLName
        End With
        wsWS.Visible = xlSheetVeryHidden 'Sheet is not visible in the sheet list, only in VBA
    End If
    If bReset Then
        With Range(sLDName)
            .Value = GetDate
        End With
    End If
    Application.ScreenUpdating = True
   
End Sub

Function GetDate() As Date
'Get the lock date
    Dim vD As Variant
   
    Do
        vD = InputBox(prompt:="Please enter date after which the sheets in" & vbCrLf & _
                            "this workbook need to be locked." & vbCrLf & _
                            "Enter as " & Format(Date, "Short Date") & ".", _
                      Title:="Workbook lock date required")
    Loop While Not IsDate(vD)
    GetDate = CDate(vD)
End Function

Sub LockSheets(sPWd As String)
'Called by Workbook_Open. Locks all sheets
    Dim wsWS As Worksheet
   
    'first unlock all sheets as we will be changing the lock status of cells
    UnlockSheets sPWd
    'then on each sheet (not on our support sheet) lock all cells and protect
    For Each wsWS In ThisWorkbook.Worksheets
        If wsWS.Name <> sHDName Then
            wsWS.Cells.Locked = True
            wsWS.Protect sPWd, DrawingObjects:=True, Contents:=True, Scenarios:=True, _
                 AllowSorting:=True, AllowFiltering:=True
            wsWS.EnableSelection = xlUnlockedCells
        End If
    Next wsWS
End Sub
Sub UnlockSheets(sPWd As String)
'Unlocks all sheets. Sets all cells to editable!
    Dim wsWS As Worksheet
   
    For Each wsWS In ThisWorkbook.Worksheets
        wsWS.Unprotect sPWd
    Next wsWS
   
End Sub

Sub SetWB2Locked(sPWd As String)
    Range(sWBLName) = True  'to mark that this process has been carried out
    LockSheets sPWd
    MsgBox prompt:="The sheets in this workbook have just been locked as the expiry date has passed.", _
           Title:="Sheets locked"

End Sub
Sub ResetLockDate()
'Allows authorised user to change the lock date
    Dim vP
    Dim dDt As Date
    Dim sMsg As String
   
    vP = InputBox(prompt:="Please enter password to change the lockdate for this workbook", _
                Title:="Password required")
    If vP = sPW Then
        dDt = GetDate
        If dDt <= Date And Date > Range(sLDName) Then
            MsgBox "Date provided does not make sense: the workbook is already locked. No action taken."
        Else
            Range(sLDName) = dDt
            If Range(sWBLName) Then
                UnlockSheets sPW
                Range(sWBLName) = False
                sMsg = "All worksheets have been unlocked. " & vbCrLf
            End If
            MsgBox sMsg & "Lock date set to: " & Format(dDt, "short date")
        End If
    Else
        MsgBox "Incorrect or no password given. No action taken"
    End If
End Sub

and this code into the workbook module:

Option Explicit

    Dim vWS

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
'Restore any sheets to unlocked, in case user had unlocked these
    Dim iC As Integer
   
    If Not IsArray(vWS) Then Exit Sub  ' Workbook has not been locked, no action required
    'else
    For iC = 1 To Me.Worksheets.Count
        If vWS(iC) = False Then            'check the original protect status of each sheet
            Worksheets(iC).Unprotect sPW    'unprotect the sheet, the user had unprotected earlier
            Me.Saved = True                 'tell Excel the workbook has been saved
        End If
    Next iC

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Set all the sheets to locked before saving, if the lock date has passed.
'This in case an authorised user has unlocked a sheet and saves the workbook
    Dim iC As Integer
    Dim wsHS As Worksheet
   
    'to enable saving workbook first time before running the code, need to check if _
     sheet ProtectSupport exists. If not skip the rest.
    On Error Resume Next
    Set wsHS = Sheets(sHDName)
    On Error GoTo 0
    If wsHS Is Nothing Then Exit Sub
   
   
    If Range(sWBLName) = False Then Exit Sub ' Workbook has not been locked, no action required
    'else
    'sometimes hidden sheet gets locked. Unlock
    wsHS.Unprotect sPW
   
    ReDim vWS(1 To Me.Worksheets.Count)
    For iC = 1 To Me.Worksheets.Count
        vWS(iC) = Worksheets(iC).ProtectContents    'store the status of protection for each sheet
        Worksheets(iC).Protect sPW, AllowSorting:=True, AllowFiltering:=True
    Next iC
End Sub

Private Sub Workbook_Open()
   
    FirstTimeSetup
    If Range(sWBLName) = True Then Exit Sub ' Workbook has been locked previously, user has unlocked
       
    'Workbook not locked, check if needs locking
    If Date < Range(sLDName) Then Exit Sub  ' Lockdate has not passed, allow user to use workbook
   
    'Workbook needs to be locked, first time
    SetWB2Locked sPW
End Sub

hello sir, good morning.iam from japan and iam using this code but it not working now. cause this type of error ,i can i fix it ? please

 

[sijpie]

OK, been busy with other things. I have rewritten some code starting from scratch. I've tested it without issues.

The first time you save the workbook, you will get prompted to enter a lock date. If you enter 0 then the workbook won't get locked until you modify the lockdate to a date.
On saving and opening the workbook, the current date will be checked against the stored lock date. If current date is larger, the sheets will all be locked.

Then there are two admin macro's: one to change the lock date, the other to unlock all sheets.

The following code needs to be copied to a normal code module. At the top (see comment starting with <<<<) you will need to modify the password.:

Option Explicit

Public Const sPW = "MyPassword"     '<<<<<  to be modified
Public Const sWSVH As String = "VHSupportSht"




Sub ResetDate()
    Dim vDT As Variant, vPW As Variant
    Dim wsVH As Worksheet
    
    vPW = InputBox(prompt:="Please enter password (unlock sheets) to change date.", _
                   Title:="Password required")
    If Not vPW = sPW Then
        MsgBox "Invalid password", _
                    Buttons:=vbCritical + vbOKOnly, _
                    Title:="Invalid password"
        Exit Sub
    End If
    
    Set wsVH = Sheets(sWSVH)
    Do
        If Len(vDT) Then MsgBox prompt:="Enter valid date or 0 to not set date", _
                                Buttons:=vbCritical + vbOKOnly, _
                                Title:="Invalid entry"
        
        vDT = InputBox(prompt:="Please enter date when to lock this workbook.", _
                     Title:="Lock date required", _
                     Default:=Format(Now + 10, "short date"))
    Loop While Not (IsDate(vDT) Or vDT = "0")
    wsVH.Range("A2") = CDate(vDT)
    
End Sub

Sub UnlockAllSheets()
    Dim vPW As Variant
    Dim wsWS As Worksheet
    
    vPW = InputBox(prompt:="Please enter password to unlock sheets.", _
                   Title:="Password required")
    If Not vPW = sPW Then
        MsgBox "Invalid password", _
                    Buttons:=vbCritical + vbOKOnly, _
                    Title:="Invalid password"
        Exit Sub
    End If

    For Each wsWS In Sheets
        wsWS.Unprotect sPW
    Next wsWS
End Sub

Now modify the password at the top of the code!!


Next you need to open the code sheet for ThisWorkbook (in the VBA editor, in the top left pane, you will see all open workbooks. Find the one you are applying this to and double click on 'ThisWorkBook' to open its code pane)
Copy the following code to the opened pane.

Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim wsVH As Worksheet
    Dim vDT As Variant
    Dim dtLD As Date
    
    On Error Resume Next
    Set wsVH = Sheets(sWSVH)
    On Error GoTo 0
    If wsVH Is Nothing Then 'support sheet doesn't exist
        Set wsVH = Sheets.Add(after:=Sheets(Sheets.Count))
        Do
            If Len(vDT) Then MsgBox prompt:="Enter valid date or 0 to not set date", _
                                    Buttons:=vbCritical + vbOKOnly, _
                                    Title:="Invalid entry"
            
            vDT = InputBox(prompt:="Please enter date when to lock this workbook.", _
                         Title:="Lock date required", _
                         Default:=Format(Now + 10, "short date"))
        Loop While Not (IsDate(vDT) Or vDT = "0")
        With wsVH
            .Range("A1") = "Lock date"
            .Range("A2") = CDate(vDT)
            .Name = sWSVH
            .Visible = xlSheetVeryHidden
        End With
    End If
    
    vDT = wsVH.Range("A2")
    
    If vDT > 0 And Date > vDT Then
        'lock sheets
        LockAll
    End If
End Sub

Private Sub Workbook_Open()
    Dim vDT As Variant
    vDT = Sheets(sWSVH).Range("A2")
    
    If vDT > 0 And Date > vDT Then
        'lock sheets
        LockAll
    End If
End Sub


Private Sub LockAll()
    Dim wsWS As Worksheet
    For Each wsWS In Me.Sheets
        If Not wsWS.Name Like sWSVH Then
            wsWS.Protect sPW, _
                        AllowSorting:=True, _
                        AllowFiltering:=True, _
                        AllowUsingPivotTables:=True
        End If
    Next wsWS
End Sub

Now save your workbook to start the process.

Note that this works. But it is 'quick and dirty': any user knowing about VBA can open the VBA editor and read the password to unlock the sheets!

If you need a safer method, let me know.

 

[raji123]

Thank you so much sijpie!