Remove password from multiple workbooks?
skrev i en meddelelse
...
Hello
I have a large number of docs (500+) that I need to move to our
company server. They are all encrypted with the same password, and I
know the password, so I don't need a cracker program, but I am looking
for a script or utility that will allow me to remove password
protection from all of these docs at once.
The below script does the trick for Word, courtesy Jay Freedman. I
would like to convert it so that it works for Excel and Powerpoint.
The key bit is to retain the fact the files are taken from a
predefined source folder and moved, with passwords removed, to a
target folder.
many thanks!
Misha
Sub removePassword()
Dim oDoc As Document
Dim fName As String
Const pwd = "password" ' to be changed
Const pathToOpen = "C:\passwordFiles\" ' to be changed
Const pathToSave = "C:\noPassword\" ' to be changed
fName = Dir$(pathToOpen & "*.doc")
If fName = "" Then
MsgBox "No *.doc files in " & pathToOpen
End If
WordBasic.DisableAutoMacros 1 ' disable any AutoOpen
On Error GoTo FinalExit
While fName < ""
Set oDoc = Documents.Open(FileName:=pathToOpen & fName, _
PasswordDocument:=pwd, AddToRecentFiles:=False)
oDoc.SaveAs FileName:=pathToSave & fName, Password:=""
oDoc.Close SaveChanges:=wdDoNotSaveChanges
fName = Dir$()
Wend
Exit Sub
FinalExit:
WordBasic.DisableAutoMacros 0 ' reenable
If Err.Number < 0 Then
Select Case Err.Number
Case 5152:
MsgBox "Could not save " & pathToSave & fName
Case Else
MsgBox Err.Number & vbCr & Err.Description
End Select
End If
End Sub
Hi Misha
Try this
Sub removePassword()
Dim oWB As Workbook
Dim fName As String
Const pwd = "password" ' to be changed
Const pathToOpen = "C:\passwordFiles\" ' to be changed
Const pathToSave = "C:\noPassword\" ' to be changed
Dim secAutomation As MsoAutomationSecurity
secAutomation = Application.AutomationSecurity
fName = Dir$(pathToOpen & "*.xls")
If fName = "" Then
MsgBox "No *.xls files in " & pathToOpen
End If
Application.AutomationSecurity = msoAutomationSecurityForceDisable
' Disable macros, should work in excel 2003
On Error GoTo FinalExit
While fName < ""
Set oWB = Workbooks.Open(Filename:=pathToOpen & fName, _
Password:=pwd, AddToRecentFiles:=False)
oWB.SaveAs Filename:=pathToSave & fName, Password:=""
oWB.Close SaveChanges:=wdDoNotSaveChanges
fName = Dir$()
Wend
Exit Sub
FinalExit:
Application.AutomationSecurity = secAutomation 'Enabel macros
If Err.Number < 0 Then
Select Case Err.Number
Case 5152:
MsgBox "Could not save " & pathToSave & fName
Case Else
MsgBox Err.Number & vbCr & Err.Description
End Select
End If
End Sub
Regards,
Per
|