Remove password from multiple workbooks?

[misha.lepetic]

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

 

[Ron de Bruin]

Untested but try this

Sub removePasswordexcel()
Dim oDoc 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

fName = Dir$(pathToOpen & "*.xls")
If fName = "" Then
MsgBox "No *.xls files in " & pathToOpen
End If

Application.ScreenUpdating = False
Application.EnableEvents = False ' disable any AutoOpen

On Error GoTo FinalExit

While fName <> ""
Set oDoc = Workbooks.Open(Filename:=pathToOpen & fName, _
Password:=pwd)
oDoc.SaveAs Filename:=pathToSave & fName, Password:=""
oDoc.Close SaveChanges:=False
fName = Dir$()
Wend

Exit Sub

FinalExit:
Application.EnableEvents = True ' reenable
Application.ScreenUpdating = True

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

 

[Per Jessen]

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