excelvbapassword-protection

VBA - Password prompts again when file is read only


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?


Solution

  • 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