VBA Workbooks.open prompting for password if somebody else is using the workbook

[bcfaigg]

Folks,
I am designing a workbook (a 'policy attestation tool') to use when launching new policies, and require (circa 800) staff to attest that they have read the launched policy. In short, the when the staff member clicks on the "attest" button, the tool will open a password-protected attestation register (on a shared drive) and update the relevant individual's record, before saving and closing the register. Where this process fails (e.g. new staff members may not yet have been given access to shared directory, or if somebody else already has the register open), then the tool will revert to an exceptions routine and generate an email to Compliance (who can then update the register accordingly).

This all works well, except that if somebody else already has the register open, then at the workbook.open step in the code, the user gets a prompt that the workbook is protected and prompts for a password (after which the register opens in readonly). Now the code should have already provided the password (and that works fine in normal situations, when the register isn't already open) - I need to get rid of that prompt and have the code revert to the exceptions process (ManualExceptionsProcess), but am struggling to find a way to do this...

Relevant (simplified) code below:

Sub Attestation()
    On Error GoTo ManualExceptionsProcess
    Application.DisplayAlerts = False
    Workbooks.Open Filename:= _
        "\\wwp\data\Investment Data\WICN\Compliance\Compliance Admin\EMEA-Investments-Policy-Attestation-Register.xlsx", Password:="password"
    If Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").ReadOnly Then 'if somebody is already in register and so opens in read-only - goto manual process
        Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Close savechanges:=False
        GoTo ManualExceptionsProcess
    End If
    On Error Resume Next
    Application.DisplayAlerts = True
    SearchEntries 'update register
   
    Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Close savechanges:=True
    Application.ScreenUpdating = True
   
    Workbooks("Policy-Attestation-Tool.xlsm").Close savechanges:=False
    End
ManualExceptionsProcess:
    Application.DisplayAlerts = True
    Sheets("Attestation").Unprotect Password:="password"
   
    x = MsgBox("I was unable to update the Policy Attestation Register." & Chr(10) & Chr(10) & "I will generate an email for you to send to Compliance, confirming you have read the required documents.", vbExclamation)
   
    SendManualAttestationEmail
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    ActiveWorkbook.Close savechanges:=False
   
End Sub

I need this to work without any alerts / needs to manually enter a password. Does anyone have any thoughts how to resolve this?
Thanks
Bcfaigg

 

[dmt32]

Hi,
try following & see if resolves your issue

Updated Attestation code

Sub Attestation()
    Dim wb As Workbook
    Dim FileName As String, FilePath As String
'workbook open password
    Const OpenPassword As String = "password"
    
    On Error GoTo exitsub
    
    FilePath = "\\wwp\data\Investment Data\WICN\Compliance\Compliance Admin\"
    FileName = "EMEA-Investments-Policy-Attestation-Register.xlsx"

    Application.ScreenUpdating = False
    Set wb = OpenRegister(FilePath & FileName, False, OpenPassword)
    
    If Not wb Is Nothing Then
'update register
        SearchEntries
'close & save register
        wb.Close True
        Set wb = Nothing
        
    Else
        
'ManualExceptionsProcess
        Sheets("Attestation").Unprotect Password:="password"
        
        MsgBox "I was unable to update the Policy Attestation Register." & Chr(10) & Chr(10) & _
        "I will generate an email for you to send to Compliance, confirming you have" & _
        "read the required documents.", vbExclamation, "Policy Attestation Register"
        
        SendManualAttestationEmail
    
    End If
    
exitsub:
    If Not wb Is Nothing Then wb.Close False
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
'close this workbook
    'ActiveWorkbook.Close savechanges:=False
End Sub

Place following Function in a STANDARD module

Function OpenRegister(ByVal FileName As String, ByVal ReadOnly As Boolean, Optional ByVal Password As String = "") As Workbook
    Dim Response As VbMsgBoxResult
    Dim FileInUse As Boolean
'dmt32 May 2020
OpenFile:
    If Not Dir(FileName, vbDirectory) = vbNullString Then
        If Not ReadOnly Then
'chaeck if file already open read/write
            On Error Resume Next
            Open FileName For Binary Access Read Lock Read As #1
            Close #1
            FileInUse = CBool(Err.Number > 0)
            On Error GoTo 0
            If FileInUse Then
'read / write file in use
                Response = MsgBox("File Is Open For Editing By Another User." & Chr(10) & _
                "Do You Want To Try Again?", 37, "File In Use")
                If Response = vbRetry Then
                    GoTo OpenFile
                Else
                    Set OpenRegister = Nothing
                    Exit Function
                End If
            End If
        End If
        Set OpenRegister = Workbooks.Open(FileName, ReadOnly:=ReadOnly, Password:=Password)
    Else
        MsgBox "File / Folder Not Found", 16, "Not Found"
        Set OpenRegister = Nothing
    End If
End Function

Hope Helpful

Dave

 

[bcfaigg]

Dave,
Thank you so much. That worked beautifully. I have tweaked your code a bit, but I now have a fully working policy attestation tool...

In the interests of sharing with anyone else who happens to find this thread / are trying to achieve something similar, I attach below my full code - which could (I think) be easily adapted for other purposes:

Public UserEmail As String
Public UserName As String
Public FullName As String
Public SelectionRow As Integer
Public NewEntry As Boolean
Public ManualSubmission As Boolean
Public AttestationDate As Date
Public objOutlook As Object
Public objMail As Object
Public wb As Workbook
Public Subject As String
Public AttestationFileName As String

Sub Reset()
    Sheets("Attestation").Unprotect Password:="password"
    Cells(27, 2) = ""
    Cells(28, 2) = ""
    Cells(29, 2) = ""
    Cells(30, 2) = ""
    ActiveSheet.Shapes("Attestation").Visible = True
    ActiveSheet.Shapes("ManualUpdate").Visible = False
   
    Sheets("Attestation").Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True
End Sub

Sub Attest()
    Dim FileName As String, FilePath As String
    x = MsgBox("Are <you working remotely (i.e. at home / away from a XYZ office)?", vbYesNo + vbQuestion, "Working remotely?")
    If x = 6 Then
        x = MsgBox("This will only work if you are connected to the XYZ VPN." & vbNewLine & vbNewLine & "Do you wish to proceed?", vbYesNo + vbQuestion, "Are you on VPN?")
        If x = 7 Then
            MsgBox "Please connect to VPN and try again", vbExclamation, "Connect to VPN"
            Exit Sub
        End If
    End If
    x = MsgBox("Do you confirm that:" & vbNewLine & "• you have read and understood the relevant collateral, and" & vbNewLine & "• you agree to comply with any requirements therein?", vbYesNo + vbQuestion, "Have you read and understood the documents?")
    If x = 7 Then
        MsgBox "OK. Please come back and complete this attestation at a later time.", vbExclamation
        Exit Sub
    End If
    MsgBox "It will take me a 5-10 seconds to update the attestation register (or a little longer if you are working remotely on VPN." & vbNewLine & vbNewLine & "Please bear with me - I will tell you when I am finished.", vbExclamation, "This may take a moment..."
   
    'workbook open password
    Const OpenPassword As String = "password"
     
    On Error GoTo exitsub
    FilePath = "\\wwp\data\Investment Data\WICN\Compliance\Compliance Admin\"
    FileName = "EMEA-Investments-Policy-Attestation-Register.xlsx"
    Application.ScreenUpdating = False
    GetUserDetails
    Set wb = OpenRegister(FilePath & FileName, False, OpenPassword)

    If Not wb Is Nothing Then
        'update register
        AttestationDate = Now
        ManualSubmission = False
        SearchEntries
   
        'close & save register
        wb.Close True
        Set wb = Nothing
        MsgBox "Thank you for confirming that you have read the relevant collateral." & vbNewLine & vbNewLine & "I have updated the register, and this Policy Attestation Tool will now close.", vbExclamation, "All done"
    Else
        'ManualExceptionsProcess
        Sheets("Attestation").Unprotect Password:="password"
        Cells(27, 2) = UserName
        Cells(28, 2) = FullName
        Cells(29, 2) = UserEmail
        Cells(30, 2) = Now
        Sheets("Attestation").Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True
       
        MsgBox "I was unable to update the Policy Attestation Register." & vbNewLine & vbNewLine & _
            "I will now generate an email for you to send to Compliance, confirming you have " & _
            "read the required documents.", vbExclamation, "Policy Attestation Register was in use"

        ActiveSheet.Shapes("Attestation").Visible = False
        ActiveSheet.Shapes("ManualUpdate").Visible = True
           
        ManualEmail
    End If
   
exitsub:
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
    If Not wb Is Nothing Then
        wb.Close False
    End If
    Workbooks("Policy-Attestation-Tool-v2.xlsm").Close savechanges:=False
       
End Sub

Sub GetUserDetails()
    Dim OL As Object
    Dim olallusers As Object
    Dim oExchUser As Object
    Dim oentry 'As Object
    Dim myitem As Object
   
    Set OL = CreateObject("outlook.application")
    Set olallusers = OL.Session.AddressLists.Item("All Users").AddressEntries

    User = OL.Session.CurrentUser.Name

    Set oentry = olallusers.Item(User)

    Set oExchUser = oentry.GetExchangeUser()

    UserEmail = oExchUser.PrimarySmtpAddress
    UserName = UCase(Environ("Username"))
   
    FullName = Left(UserEmail, InStr(UserEmail, "@") - 1)
    FullName = Replace(FullName, ".", " ")
    FirstName = Left(UserEmail, InStr(UserEmail, ".") - 1)
    UserEmail = LCase(UserEmail)
   
End Sub

Sub SearchEntries()
    SelectionRow = 1
    Do While Cells(SelectionRow, 1) <> ""
        If LCase(Cells(SelectionRow, 1)) = UserEmail Then
            Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Sheets("Sheet1").Cells(SelectionRow, 2) = AttestationDate
            Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Sheets("Sheet1").Cells(SelectionRow, 3) = UserName
            Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Sheets("Sheet1").Cells(SelectionRow, 4) = FullName
            Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Sheets("Sheet1").Cells(SelectionRow, 5) = False 'New entry
            Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Sheets("Sheet1").Cells(SelectionRow, 6) = ManualSubmission
            Exit Sub
        End If
        SelectionRow = SelectionRow + 1
    Loop
    Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Sheets("Sheet1").Cells(SelectionRow, 1) = UserEmail
    Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Sheets("Sheet1").Cells(SelectionRow, 2) = AttestationDate
    Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Sheets("Sheet1").Cells(SelectionRow, 3) = UserName
    Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Sheets("Sheet1").Cells(SelectionRow, 4) = FullName
    Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Sheets("Sheet1").Cells(SelectionRow, 5) = True 'New entry
    Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Sheets("Sheet1").Cells(SelectionRow, 6) = ManualSubmission
   
End Sub

Sub ManualEmail()
'generates manual attestation email
    Set wb = ActiveWorkbook
   
    Subject = UCase(FullName) & "-" & Cells(2, 2) & "-attestation"
   
    AttestationFileName = Replace(Subject, " ", "_") & ".xlsm"
   
    MsgBox "Don't forget to send the attestation email.", vbInformation, "Make sure you send the email"
   
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
       
    With objMail
        .To = "Compliance@xyz.com"
        .Subject = Subject
        .HTMLBody = "Dear Compliance,<br>I confirm that I have read and understood the relevant collateral to which this attestation relates.  <b><font color=red>I will ensure I comply with the requirements therein at all times.</font></b><br>Regards<br>" & FullName
        wb.Activate
        wb.SaveCopyAs Environ("temp") & "\" & AttestationFileName
        .Attachments.Add (Environ("temp") & "\" & AttestationFileName)
        .Display
    End With
   
    Kill Environ("temp") & "\" & AttestationFileName
    Set objOutlook = Nothing
    Set objMail = Nothing
End Sub


Sub ManualUpdateRegister()

    UserName = Cells(27, 2)
    FullName = Cells(28, 2)
    UserEmail = Cells(29, 2)
    AttestationDate = Cells(30, 2)
    ManualSubmission = True
   
    AttestationFileName = ActiveWorkbook.Name
    On Error Resume Next
    Workbooks.Open FileName:= _
        "\\wwp\data\Investment Data\WICN\Compliance\Compliance Admin\EMEA-Investments-Policy-Attestation-Register.xlsx", Password:="password"
   
    SearchEntries
continue:
    x = MsgBox("Do you want to close the EMEA Investments Policy Attestation Register?", vbYesNo + vbQuestion)
    If x = 6 Then
        Workbooks("EMEA-Investments-Policy-Attestation-Register.xlsx").Close savechanges:=True
        Else: MsgBox "OK. Don't forget to save the register before closing!", vbExclamation
    End If
    Workbooks(AttestationFileName).Close savechanges:=False
End Sub

Function OpenRegister(ByVal FileName As String, ByVal ReadOnly As Boolean, Optional ByVal Password As String = "") As Workbook
    Dim FileInUse As Boolean
'dmt32 May 2020
OpenFile:
    If Not Dir(FileName, vbDirectory) = vbNullString Then
        If Not ReadOnly Then
'check if file already open read/write
            On Error Resume Next
            Open FileName For Binary Access Read Lock Read As #1
            Close #1
            FileInUse = CBool(Err.Number > 0)
            On Error GoTo 0
            If FileInUse Then
'read / write file in use
                Set OpenRegister = Nothing
                Exit Function
                'End If
            End If
        End If
        Set OpenRegister = Workbooks.Open(FileName, ReadOnly:=ReadOnly, Password:=Password)
    Else
        MsgBox "File / Folder Not Found", 16, "Not Found"
        Set OpenRegister = Nothing
    End If
End Function

 

[dmt32]

Dave,
Thank you so much. That worked beautifully. I have tweaked your code a bit, but I now have a fully working policy attestation tool...

Most welcome - I created that function about 10 years ago for charity my daughter worked for where over 250 staff submitted times-sheets each week - as her employer had no licence for MS Access, I created an Excel workbook database for users to submit their data to & managed read / write access with the Function & seemed to perform ok - Not published it before but hopefully others will find it helpful

Many thanks for feedback - always appreciated by all who contribute for a request for help

Dave