How do I run a VBA Sub routine continuously when working in a Workbook and not only when the Workboo-CodePudding

I have made a sub routine to check for a password and a pre-defined expiry date. The code works, but only upon opening the Excel Workbook. Here is some code to show what I have so far:

Private Sub Workbook_Open()

Dim j, i, trials, passCnt As Integer
trials = 3 'Number of trials
passCnt = 4 'Number of times to enter password
j = 1
ReDim AllPassWords(1 To trials) As String
AllPassWords(1) = "123"
AllPassWords(2) = "456"
AllPassWords(3) = "789"

ReDim ExpDate(1 To trials) As Date 'We pre-define the expiry dates and passwords
ExpDate(1) = CStr(DateSerial(2023, 1, 13)   TimeSerial(8, 49, 0))
ExpDate(2) = CStr(DateSerial(2023, 1, 13)   TimeSerial(8, 51, 0))
ExpDate(3) = CStr(DateSerial(2023, 1, 13)   TimeSerial(8, 53, 0))

Dim PassWord As String 'User password 

If CDate(Now) < ExpDate(j) Then 'If the jth trial has not expired we do the following

    If j = 1 Then
        For i = 1 To passCnt ' chances to enter password
            'Enter password before we can use the worksheet
            PassWord = InputBox("Please input password.")
            If PassWord = AllPassWords(j) Then
            
                Exit For
                
                ElseIf i < passCnt Then
                    MsgBox "Incorrect password. " & passCnt - i & " attempts remaining."
                
                ElseIf i = passCnt Then
                    MsgBox "Password limit reached. Closing workbook"
                    ThisWorkbook.Close
                
            End If
        Next i
    
    MsgBox ("You have " & ExpDate(j) - CDate(Now) & " days left")
        
    
    End If
    
    Else: MsgBox "Trial " & j & " has expired. New password will be required to continue"
        j = j   1
End If

I need this sub to run while the Workbook is open so that when the Expiry date is exceeded the application will ask for a new password. The user could just keep the Workbook open and have the trial last indefinitely. The other problem I'm worried about is that the 'msgbox' will pop up every time the code is executed. Is there a way to run the code while the Workbook is open, but simultaneously block the msgbox display, except for when the user opens the workbook?

CodePudding user response：

you could do like

on Thisworkbook, put:

Private Sub Workbook_Open()

Call checkPW(True)

End Sub

then create two others macros in a separate module

Option Explicit

Sub checkPW(Optional firstRun As Boolean)

Dim j, i, trials, passCnt As Integer
trials = 3 'Number of trials
passCnt = 4 'Number of times to enter password
j = 1
ReDim AllPassWords(1 To trials) As String
AllPassWords(1) = "123"
AllPassWords(2) = "456"
AllPassWords(3) = "789"

ReDim ExpDate(1 To trials) As Date 'We pre-define the expiry dates and passwords
ExpDate(1) = CStr(DateSerial(2023, 1, 14)   TimeSerial(8, 49, 0))
ExpDate(2) = CStr(DateSerial(2023, 1, 15)   TimeSerial(8, 51, 0))
ExpDate(3) = CStr(DateSerial(2023, 1, 16)   TimeSerial(8, 53, 0))

Dim PassWord As String 'User password

If CDate(Now) < ExpDate(j) Then 'If the jth trial has not expired we do the following

    If j = 1 Then
        For i = 1 To passCnt ' chances to enter password
            'Enter password before we can use the worksheet
            PassWord = InputBox("Please input password.")
            If PassWord = AllPassWords(j) Then
            
                Exit For
                
                ElseIf i < passCnt Then
                    MsgBox "Incorrect password. " & passCnt - i & " attempts remaining."
                
                ElseIf i = passCnt Then
                    MsgBox "Password limit reached. Closing workbook"
                    ThisWorkbook.Close
                
            End If
        Next i
    
    MsgBox ("You have " & ExpDate(j) - CDate(Now) & " days left")
 
    End If

    Else:
    
    If firstRun = True Then
    MsgBox "Trial " & j & " has expired. New password will be required to continue"
    End If
        j = j   1
End If

Call macro_timer

End Sub


Sub macro_timer()

'Tells Excel when to next run the macro.
Application.OnTime Now   TimeValue("00:00:10"), "checkPW"

End Sub

I used

    If firstRun = True Then
    MsgBox "Trial " & j & " has expired. New password will be required to continue"
    End If

to define what to show only when workbook is opened, you can adjust as you need

CodePudding user response：

I think this may work. I added another Sub routine that checks whether any of the Worksheets are altered or cells are clicked on. The new Sub Workbook_SheetChange then checks the same pre-defined dates and calls the original Sub Workbook_Open. Thus while the Workbook is open the user will receive the message that the trial has expired and a new password is required to begin the next trial. Here is the code:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)

'This just needs to cont. checking the expiry date

ReDim ExpDate(1 To 3) As Date 'We pre-define the expiry dates

ExpDate(1) = CStr(DateSerial(2023, 1, 13)   TimeSerial(18, 34, 0))
ExpDate(2) = CStr(DateSerial(2023, 1, 13)   TimeSerial(18, 51, 0))
ExpDate(3) = CStr(DateSerial(2023, 1, 13)   TimeSerial(18, 53, 0))

If CDate(Now) > ExpDate(1) And CDate(Now) < ExpDate(2) Then
   Workbook_Open
   ElseIf CDate(Now) > ExpDate(2) And CDate(Now) < ExpDate(3) Then
      Workbook_Open
      ElseIf CDate(Now) > ExpDate(3) Then
          Workbook_Open

End If

End Sub

Private Sub Workbook_Open()

Dim j, i, trials, passCnt As Integer
trials = 3 'Number of trials
passCnt = 4 'Number of times to enter password
j = 1
ReDim AllPassWords(1 To trials) As String
AllPassWords(1) = "123"
AllPassWords(2) = "456"
AllPassWords(3) = "789"

ReDim ExpDate(1 To trials) As Date 'We pre-define the expiry dates and passwords
ExpDate(1) = CStr(DateSerial(2023, 1, 13)   TimeSerial(18, 34, 0))
ExpDate(2) = CStr(DateSerial(2023, 1, 13)   TimeSerial(18, 51, 0))
ExpDate(3) = CStr(DateSerial(2023, 1, 13)   TimeSerial(18, 53, 0))

Dim PassWord As String

If CDate(Now) < ExpDate(j) Then 'If the jth trial has not expired we do the following

    If j = 1 Then
        For i = 1 To passCnt ' chances to enter password
            'Enter password before we can use the worksheet
            PassWord = InputBox("Please input password.")
            If PassWord = AllPassWords(j) Then
            
                Exit For
                
                ElseIf i < passCnt Then
                    MsgBox "Incorrect password. " & passCnt - i & " attempts remaining."
                
                ElseIf i = passCnt Then
                    MsgBox "Password limit reached. Closing workbook"
                    ThisWorkbook.Close
                
            End If
        Next i
    
    MsgBox ("You have " & ExpDate(j) - CDate(Now) & " days left")
        
    
    End If
    
    Else: MsgBox "Trial " & j & " has expired. New password will be required to continue"
        j = j   1
End If


If CDate(Now) < ExpDate(j) Then 'If the jth trial has not expired we do the following

    If j = 2 Then
        For i = 1 To passCnt ' chances to enter password
            'Enter password before we can use the worksheet
            PassWord = InputBox("Please input password.")
            If PassWord = AllPassWords(j) Then
            
                Exit For
                
                ElseIf i < passCnt Then
                    MsgBox "Incorrect password. " & passCnt - i & " attempts remaining."
                
                ElseIf i = passCnt Then
                    MsgBox "Password limit reached. Closing workbook"
                    ThisWorkbook.Close
                
            End If
        Next i
    
    MsgBox ("You have " & ExpDate(j) - CDate(Now) & " days left")
        
    
    End If
    
    Else: MsgBox "Trial " & j & " has expired. New password will be required to continue"
        j = j   1
End If


If CDate(Now) < ExpDate(j) Then 'If the jth trial has not expired we do the following

    If j = 3 Then
        For i = 1 To passCnt ' chances to enter password
            'Enter password before we can use the worksheet
            PassWord = InputBox("Please input password.")
            If PassWord = AllPassWords(j) Then
            
                Exit For
                
                ElseIf i < passCnt Then
                    MsgBox "Incorrect password. " & passCnt - i & " attempts remaining."
                
                ElseIf i = passCnt Then
                    MsgBox "Password limit reached. Closing workbook"
                    ThisWorkbook.Close
                
            End If
        Next i
    
    MsgBox ("You have " & ExpDate(j) - CDate(Now) & " days left")
        
    
    End If
    
    Else: MsgBox "Trial " & j & " has expired. New password will be required to continue"
        j = j   1
End If

If j > trials Then
    'Here we have run out of all trials and we must end the function completely
    MsgBox "Trials have ended. Add-in will be terminated."
End If

  
End Sub