VBA - Password prompts again when file is read only

Question

i have an issue where the combination of password protection and read only interferes. I have a "data collector" where a lot of people fill in another form and transfer the data via a button. I wanna check if this file everyone writes in is read only (preventing data from not getting lost) and if so you get a message that a transfer is currently in progress and if he/she want's to wait a bit or cancel the process... I realised that as long as the Data Collector is password protected, the macro stops as soon as the file IS read only even though i provided the password.

Sub Readonlytest()
Dim OpenAgain As Integer
DoAgain:
Application.DisplayAlerts = False
Workbooks.Open Filename:= _
"Path\ReadOnly Test.xlsx", Password:="PW"
If Workbooks("ReadOnly Test.xlsx").ReadOnly Then
    Workbooks("ReadOnly Test.xlsx").Close (False)
    Application.DisplayAlerts = True
    OpenAgain = MsgBox("Data Transfer in progress. Try again?", vbYesNo)
    
    If OpenAgain = vbYes Then
        Application.Wait (Now + TimeValue("00:00:04"))
        GoTo DoAgain
    End If
    If OpenAgain = vbNo Then
        MsgBox "Try again later."
        Exit Sub
    End If
End If

Any ideas?

• Setting Display Alerts to false didn't work
• when not opened by anyone everything works fine
• if workbook isn't password protected this code works as well

Answer 1

Check if this works:

Option Explicit

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
       (ByVal ClassName As String, ByVal WindowName As String) As LongPtr

Private Declare PtrSafe Function SetForegroundWindow Lib "user32" _
       (ByVal hwnd As LongPtr) As LongPtr
       
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As LongPtr

Private Sub Sleep(Milisegundos As Long, Optional ByVal HabilitaEventos As Boolean = True)
    Dim agora As LongPtr, Fim As LongPtr
    agora = GetTickCount
    Fim = agora + Milisegundos
    Do While GetTickCount < Fim
        DoEvents
    Loop
End Sub

Sub Readonlytest()

    'Change theses constants to your country!!
    Const cFileInUse = "Arquivo em uso"
    Const cPassword = "Senha"
    
    Dim OpenAgain As Integer
DoAgain:
    'Application.DisplayAlerts = False
    
   ' Find the number of instances of excel
    Dim objInstanceExcel As Object
    Dim qtExcel As Long
    Set objInstanceExcel = GetObject("winmgmts:").ExecQuery("select * from win32_process where name='excel.exe'")
    qtExcel = objInstanceExcel.Count

    'Open a new instance of excel to open the file
    Shell """C:\Program Files\Microsoft Office\Office16\EXCEL.EXE"" /E ""D:\ReadOnly Test.xlsx""", vbMaximizedFocus
    Dim hwnd As LongPtr
    'Wait the load of the new instance
    Do While objInstanceExcel.Count = qtExcel
        Sleep 200 '
        Set objInstanceExcel = GetObject("winmgmts:").ExecQuery("select * from win32_process where name='excel.exe'")
    Loop
    
    Dim i As Long
    hwnd = FindWindow("bosa_sdm_XL9", cFileInUse)
    
    Do While hwnd = 0 And i < 5 'Change the number of tries if necessary
        Sleep 1000
        hwnd = FindWindow("bosa_sdm_XL9", cFileInUse)
        i = i + 1
    Loop
    'Find the "File in use" dialog
    hwnd = FindWindow("bosa_sdm_XL9", cFileInUse)
    If hwnd <> 0 Then 'The file is in use. We need to close it
        'Force the focus on the window
        'MouseClickHwnd hwnd
        SetForegroundWindow hwnd
        'Cancel msgbox and close the instance
        SendKeys "{ESCAPE}%{F4}"
        
        'Application.DisplayAlerts = True
        OpenAgain = MsgBox("Data Transfer in progress. Try again?", vbYesNo)

        If OpenAgain = vbYes Then
            Sleep 4000
            'Application.Wait (Now + TimeValue("00:00:04"))
            GoTo DoAgain
        Else 'End If
             'If OpenAgain = vbNo Then
            MsgBox "Try again later."
            Exit Sub
        End If
    Else 'Ok Open file with password in other process
        'Find the "Password" dialog
        hwnd = FindWindow("bosa_sdm_XL9", cPassword)
        Do While hwnd = 0
            Sleep 100
            hwnd = FindWindow("bosa_sdm_XL9", cPassword)
        Loop
        'Force the focus on the window
        SetForegroundWindow hwnd
        'Send the password
        SendKeys "PW{ENTER}"
    End If
End Sub