Modify Password change all files in folders and subfolders, read only recommended

Hey,

I have a folder contain subfolders that have multiple files all containing the same password and same settings.
Password to modify and the box ticked for read only recommended. No password to open.

I would like to change the password all of these files.

The only answers i can find for similar questions are to change just the password for opening and not applying any read only recommended options either.

If this is possible and someone can help this would be much appreciated!

Thanks in advance.

Marcosis

Possibly...

Option Explicit
Sub PW_Change()

    '<<< Not Tested - Run on a copy of your files >>>>
    
    Dim AllFolders As Object, AllFiles As Object
    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i As Integer, k As Variant
    Dim OldPW As String, NewPW As String
    
    'Change these as needed
    MyPath = "C:\Temp\"
    OldPW = "Old Password"
    NewPW = "New Password"
    
    Set AllFolders = CreateObject("Scripting.Dictionary")
    Set AllFiles = CreateObject("Scripting.Dictionary")
    
    'Get all folders and any subfolders
    AllFolders.Add (MyPath), ""
    i = 0
    Do While i < AllFolders.Count
        k = AllFolders.keys
        MyFolderName = Dir(k(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(k(i) & MyFolderName) And vbDirectory) = vbDirectory Then
                    AllFolders.Add (k(i) & MyFolderName & "\"), ""
                End If
            End If
            MyFolderName = Dir
        Loop
        i = i + 1
    Loop
    
    'Get all files in all folders and subfolders
    For Each k In AllFolders.keys
        MyFileName = Dir(k & "*.*")
        Do While MyFileName <> ""
            If Right(MyFileName, 5) = ".xlsx" Then
                AllFiles.Add (k & MyFileName), ""
            End If
            MyFileName = Dir
        Loop
    Next k
    
    'Change passwords
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        
        For Each k In AllFiles.keys
            Workbooks.Open Filename:=k, writeresPassword:=OldPW, ignorereadonlyrecommended:=True
            ActiveWorkbook.SaveAs k, writeresPassword:=NewPW, ReadOnlyRecommended:=True
            ActiveWorkbook.Close
        Next k
        
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    Set AllFolders = Nothing
    Set AllFiles = Nothing
End Sub

Originally Posted by dangelor

Possibly...

Option Explicit
Sub PW_Change()

    '<<< Not Tested - Run on a copy of your files >>>>
    
    Dim AllFolders As Object, AllFiles As Object
    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i As Integer, k As Variant
    Dim OldPW As String, NewPW As String
    
    'Change these as needed
    MyPath = "C:\Temp\"
    OldPW = "Old Password"
    NewPW = "New Password"
    
    Set AllFolders = CreateObject("Scripting.Dictionary")
    Set AllFiles = CreateObject("Scripting.Dictionary")
    
    'Get all folders and any subfolders
    AllFolders.Add (MyPath), ""
    i = 0
    Do While i < AllFolders.Count
        k = AllFolders.keys
        MyFolderName = Dir(k(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(k(i) & MyFolderName) And vbDirectory) = vbDirectory Then
                    AllFolders.Add (k(i) & MyFolderName & "\"), ""
                End If
            End If
            MyFolderName = Dir
        Loop
        i = i + 1
    Loop
    
    'Get all files in all folders and subfolders
    For Each k In AllFolders.keys
        MyFileName = Dir(k & "*.*")
        Do While MyFileName <> ""
            If Right(MyFileName, 5) = ".xlsx" Then
                AllFiles.Add (k & MyFileName), ""
            End If
            MyFileName = Dir
        Loop
    Next k
    
    'Change passwords
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        
        For Each k In AllFiles.keys
            Workbooks.Open Filename:=k, writeresPassword:=OldPW, ignorereadonlyrecommended:=True
            ActiveWorkbook.SaveAs k, writeresPassword:=NewPW, ReadOnlyRecommended:=True
            ActiveWorkbook.Close
        Next k
        
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    Set AllFolders = Nothing
    Set AllFiles = Nothing
End Sub

Hey, thanks for the response. Is that supposed to go into the module of a new workbook?

If so nothings happening. It doesn't fail, it just does nothing. Any help would be appreciated

Cheers

Originally Posted by dangelor

It would go into a standard code module of the workbook of your choice, saved as an .xlsm or .xlsb file format.

As to it doing something, it should change the password in your files from the 'old' to the 'new' password.

Before you run the code, be sure to change the 3 bolded variables in the code to match your situation.

When the code finishes running, check to see if you can open your files using the new password.

Worked like an absolute dream!

Cheers dude!

Glad I could help!

Originally Posted by dangelor

Glad I could help!

Hey!

So i jumped the gun a bit haha!

I tested it on 6 spreadsheets and it worked great.

I just tried to run it on the ones that i needed which, at the time, i didnt realise that it was 1008 spreadsheets! My colleague didnt warn me.

It changed alot of them, but threw up an error, saying it could access one of them. Maybe he didnt set the correct password for example.

Is there a way to add something like On Error Resume Next somewhere. I only found that with some research, but wasnt sure if that was the correct way to go about it.

The other thing was that some of the files are .xlsx , so could it be changed to look for anything containing *.xls* for example, because looking at the code you provided, it looks at the last 4 characters for that, but if i change it, it throws up an error about the others.

So to round up, it would be great if it could ignore errors and move on (the dream being it listing the files causing the issue) but if thats a pain, not a problem.

And to also search for files containing xls

Cheers

Please don't quote entire posts unnecessarily. They clutter threads and make them hard to read.
Use the "Quick reply" instead
Thanks

My bad!

Cheers

Try this version...

Option Explicit
Sub PW_Change_v3()

    '<<< Not Tested - Run on a copy of your files >>>>

    Dim AllFolders As Object, AllFiles As Object
    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i As Integer, k As Variant
    Dim OldPW As String, NewPW As String, s As String

    'Change these as needed
    MyPath = "C:\Temp\"
    OldPW = "Old Password"
    NewPW = "New Password"
    
    Set AllFolders = CreateObject("Scripting.Dictionary")
    Set AllFiles = CreateObject("Scripting.Dictionary")
    
    'Get all folders and any subfolders
    AllFolders.Add (MyPath), ""
    i = 0
    Do While i < AllFolders.Count
        k = AllFolders.keys
        MyFolderName = Dir(k(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(k(i) & MyFolderName) And vbDirectory) = vbDirectory Then
                    AllFolders.Add (k(i) & MyFolderName & "\"), ""
                End If
            End If
            MyFolderName = Dir
        Loop
        i = i + 1
    Loop
    
    'Get all files in all folders and subfolders
    For Each k In AllFolders.keys
        MyFileName = Dir(k & "*.xls*")
        Do While MyFileName <> ""
            AllFiles.Add (k & MyFileName), ""
            MyFileName = Dir
        Loop
    Next k
    
    'Change passwords
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        
        On Error Resume Next
        For Each k In AllFiles.keys
            Workbooks.Open Filename:=k, writeresPassword:=OldPW, ignorereadonlyrecommended:=True
            If Err = 1004 Then
                s = s & vbNewLine & k
                Err.Clear
                GoTo Skip
            End If
            ActiveWorkbook.SaveAs k, writeresPassword:=NewPW, ReadOnlyRecommended:=True
            ActiveWorkbook.Close
Skip:
        Next k
        On Error GoTo 0
        
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    MsgBox "These files were not changed - incorrect password. " & s, vbInformation, "Incorrect Password"
    
    Set AllFolders = Nothing
    Set AllFiles = Nothing
End Sub