Solved: Change Password - Multiple Files+Common Password

[parttime_guy]

Hi Guz-n-Galz,

I am back with this strange problem. I am using MS Excel 2007 and this code does not seem to run.

I have around 450+ files in excel – all these files have a common password (I need to change the password of all these files). I found the solution and have been using the same successfully till my office planned to move to MS Excel 2007.

The problem is that this code runs perfectly on MS Excel 2003 (but seems to give up when I try to run it on MS Excel 2007).

My earlier posts on vbaexpress.com
http://www.vbaexpress.com/forum/showthread.php?t=28020

Below is the final code with examples – the sample files have a common password “123”. (Please try to use MS Excel 2007 while testing the sample)

After much search on the net, I have come across these links which address the above problems
http://bainsworld.vox.com/library/post/error-in-excel-2007-workbooksopen-method-handling-xlsx-file.html
http://vbaadventures.blogspot.com/2009/01/possible-error-in-excel-2007.html

Kindly help!!! (comments – solutions – tips – tricks…… jokes anything will do)

Best regards

[SamT]

I'm using 2003, so I can't help you directly, but reading those links, I saw this:

"And if there is a "workbook protection" password on an xlsx file and no password argument is provided to the Open method, it opens the file without any trouble."

What I'm thinking is that you try first without the bassword argument and if it fails, pass it to the file open procedure that has the argument.

Idunnowotimtawkinbout
AKA SamT

[Aussiebear]

Idunnowotimtawkinbout
AKA SamT

I don't believe this for a minute there SamT

[SamT]

I don't believe this for a minute there SamT

High praise indeed.

But I still feel like a noob.

SamT

[parttime_guy]

Sub Remove_password()
 
Dim wkb1 As Workbook
Dim wksMACRO As Worksheet
Dim fso, f, fs, f1
 
Application.DisplayAlerts = False
 
ThisWorkbook.Activate
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder(ThisWorkbook.path)
Set fs = f.Files
For Each f1 In fs
If ThisWorkbook.Name <> f1.Name Then
Set wkb1 = Application.Workbooks.Open(ThisWorkbook.path & "\" & f1.Name, , , , "123", True)
 
wkb1.Password = ""
wkb1.Save
wkb1.Close
 
End If
Next
 
Application.DisplayAlerts = True
End Sub

Is it possible to pick up the Old & New Password's from particular cells in the worksheet (eg B1 & B2). I do not want the users to open and Edit the code.

Any Ideas?

Kindly Help

Thx-n-BR

[SamT]

Do you know the old and new passwords?

wkb1.Password = ThisWorkbook.Range("B1").Text

[parttime_guy]

Hi Everybody,

With help from MD

http://www.vbaexpress.com/forum/showthread.php?t=31236

I have pasted the final code below:

[VBA]
Sub Remove_password()

Dim wkb1 As Workbook
Dim wksMACRO As Worksheet
Dim fso, f, fs, f1
Dim FileExtStr As String
Dim Filter As String
'------Password's need to be entered in Sheet1
Set Pass1 = Sheet1.Range("B1")
Set Pass2 = Sheet1.Range("B2")
Application.DisplayAlerts = False

ThisWorkbook.Activate

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder(ThisWorkbook.path)
Set fs = f.Files

For Each f1 In fs
If Right(f1.Name, 3) = "xls" Then
If ThisWorkbook.Name <> f1.Name Then
' For Each f1 In fs
' If ThisWorkbook.Name <> f1.Name Then
Set wkb1 = Application.Workbooks.Open(ThisWorkbook.path & "\" & f1.Name, , , , Pass1, True)
wkb1.Password = Pass2
wkb1.Save
wkb1.Close

End If
End If
Next

MsgBox "Congratulations!!!" & vbCrLf & "All Files in the path have been updated successfully"

Application.DisplayAlerts = True

End Sub
[/VBA]

Hope this helps users.

BR