VBA PathFile Directory & Remove Password

[unknownymous]

Hi Guys,

Can you possibly help me tweak this code? I'm thinking in Sheet1, I'll put the pathfile link in Cell F1 then Password in Cell F2. Also, how to avoid getting error when the file is in read-only format.

= = = = = =
Sub PasswordRemover()

Dim wBook As Workbook
Dim strFilename As String
'Const fPath As String = "C:\Users\Documents\"
Const strPassword As String = "12345ABC&D" 'case sensitive
Const strEditPassword As String = "12345ABC&D" 'If no password use ""
strFilename = Dir$(fPath & "*.xls") 'will open xls & xlsx etc

While Len(strFilename) <> 0
Application.DisplayAlerts = False
Set wBook = Workbooks.Open(Filename:=fPath & strFilename, _
Password:=strPassword, _
WriteResPassword:=strEditPassword)
'ActiveWorkbook.ChangeFileAccess Mode:=xlReadWrite

wBook.SaveAs Filename:=fPath & strFilename, CreateBackup:=False, WriteResPassword:="", Password:="" ', ReadOnlyRecommended:=False

wBook.Close 0
Application.DisplayAlerts = True
strFilename = Dir$()
Wend


End Sub


Any thoughts will be much appreciated.

Thank you!

 

[cmowla]

I assume that all the Workbooks have a sheet named "Sheet1" and that if the file is read-only, to SKIP it. (Excel Workbook files can show up as read only when you try to open them when they are already opened.) Then the following may be what you want. (Just let us know . . . I didn't run this code, BTW.)

Sub PasswordRemover()

Dim wBook As Workbook
Dim strFilename As String
'Const fPath As String = "C:\Users\Documents\"
Const strPassword As String = "12345ABC&D" 'case sensitive
Const strEditPassword As String = "12345ABC&D" 'If no password use ""
strFilename = Dir$(fPath & "*.xls") 'will open xls & xlsx etc

'Application.DisplayAlerts = False
While Len(strFilename) <> 0
    If GetAttr(fName) And vbReadOnly <> 1 Then 'If it's read only, skip it.
        Set wBook = Workbooks.Open(fileName:=fPath & strFilename, Password:=strPassword, WriteResPassword:=strEditPassword)
        'ActiveWorkbook.ChangeFileAccess Mode:=xlReadWrite
        With wBook
            .Sheets("Sheet1").Range("F1").Value = fPath & strFilename
            .Sheets("Sheet1").Range("F2").Value = strPassword
            .SaveAs fileName:=fPath & strFilename, CreateBackup:=False, WriteResPassword:="", Password:="" ', ReadOnlyRecommended:=False
            .Close 0
        End With
        strFilename = Dir$()
    End If
Loop
'Application.DisplayAlerts = True

End Sub

 

[unknownymous]

Tha

I assume that all the Workbooks have a sheet named "Sheet1" and that if the file is read-only, to SKIP it. (Excel Workbook files can show up as read only when you try to open them when they are already opened.) Then the following may be what you want. (Just let us know . . . I didn't run this code, BTW.)

Sub PasswordRemover()

Dim wBook As Workbook
Dim strFilename As String
'Const fPath As String = "C:\Users\Documents\"
Const strPassword As String = "12345ABC&D" 'case sensitive
Const strEditPassword As String = "12345ABC&D" 'If no password use ""
strFilename = Dir$(fPath & "*.xls") 'will open xls & xlsx etc

'Application.DisplayAlerts = False
While Len(strFilename) <> 0
    If GetAttr(fName) And vbReadOnly <> 1 Then 'If it's read only, skip it.
        Set wBook = Workbooks.Open(fileName:=fPath & strFilename, Password:=strPassword, WriteResPassword:=strEditPassword)
        'ActiveWorkbook.ChangeFileAccess Mode:=xlReadWrite
        With wBook
            .Sheets("Sheet1").Range("F1").Value = fPath & strFilename
            .Sheets("Sheet1").Range("F2").Value = strPassword
            .SaveAs fileName:=fPath & strFilename, CreateBackup:=False, WriteResPassword:="", Password:="" ', ReadOnlyRecommended:=False
            .Close 0
        End With
        strFilename = Dir$()
    End If
Loop
'Application.DisplayAlerts = True

End Sub

Thanks for this. I do wanted to omit his code and put it on the cell as mention.

Const strPassword As String = "12345ABC&D" 'case sensitive
Const strEditPassword As String = "12345ABC&D" 'If no password use ""

Appreciate your help.