Word 2010 Macro to remove password and save document

[MHamid]

Hello, I need a macro for Word 2010 that will remove a password and save the document in a specified folder using the number in the footer.

Is this possible and can someone please direct me.

Thank you,
Miriam

[gmayor]

What does the password protect against? I take it that you know the password? What EXACTLY is in the footer.

[MHamid]

Hello, yes I do know the password. The issue is that I have to save these word documents without the password. I would actually like a vba code that would save the file with the current name. The issue I'm having with this is that each file has its own name. If there's a way to do this without directing it to the footer to the case number, then that would be better.

Thank you,
miriam

[gmayor]

OK, but what does the password protect against? Opening? Editing? Forms? The following will remove the write and open passwords and save the document with the same name, provided they are used when the document is opened.


Sub SaveWithoutPassword()
Dim strName As String
Const strPW As String = ""
If Len(ActiveDocument.Path) = 0 Then
MsgBox "Document is not saved"
GoTo lbl_Exit
End If
strName = ActiveDocument.FullName
ActiveDocument.Range.InsertAfter Chr(32)
ActiveDocument.Characters.Last.Delete
ActiveDocument.SaveAs2 Filename:=strName, _
Password:=strPW, _
WritePassword:=strPW, _
ReadOnlyRecommended:=False
lbl_Exit:
Exit Sub
End Sub

[MHamid]

Hello,

The password protects against opening the file.
I have a specific location to save the file, where would I insert the directory path?


thank you,
Miriam

[gmayor]

The following will save to "C:\Path\" (which must exist). Change to the required path and don't forget the final backslash.


Sub SaveWithoutPassword()
Dim strName As String
Const strPW As String = ""
Const strPath As String = "C:\Path\" 'the path to which to save the document

If Len(ActiveDocument.Path) = 0 Then
MsgBox "Document is not saved"
GoTo lbl_Exit
End If
strName = ActiveDocument.name
ActiveDocument.Range.InsertAfter Chr(32)
ActiveDocument.Characters.Last.Delete
ActiveDocument.SaveAs2 Filename:=strPath & strName, _
Password:=strPW, _
WritePassword:=strPW, _
ReadOnlyRecommended:=False
lbl_Exit:
Exit Sub
End Sub

[MHamid]

Hello,

The macro works great! Is there any way that I can get the macro to close the document after it saves? Also, is there a way to get the code to save the file as the same name and add 2 or 3 or 4 if the files already exists?

Thank you,
Miriam

[gmayor]

The following will both close the document and save with a unique name. The latter requires a couple of extra functions:

Option Explicit

Sub SaveWithoutPassword()
Dim strName As String
Dim strExt As String
Const strPW As String = ""
Const strPath As String = "C:\Path\" 'the path to which to save the document

If Len(ActiveDocument.Path) = 0 Then
MsgBox "Document is not saved"
GoTo lbl_Exit
End If
strName = ActiveDocument.name
strExt = Mid(strName, InStrRev(strName, Chr(46)))
strName = FileNameUnique(strPath, strName, strExt)
ActiveDocument.Range.InsertAfter Chr(32)
ActiveDocument.Characters.Last.Delete
ActiveDocument.SaveAs2 Filename:=strPath & strName, _
AddToRecentFiles:=False, _
Password:=strPW, _
WritePassword:=strPW, _
ReadOnlyRecommended:=False
ActiveDocument.Close 0
lbl_Exit:
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFilename As String, _
strExtension As String) As String
'Graham Mayor
'Requires the use of the FileExists function
'strPath is the path in which the file is to be saved
'strFilename is the filename to check
'strExtension is the extension of the filename to check
Dim lngF As Long
Dim lngName As Long
lngF = 1
strExtension = Replace(strExtension, Chr(46), "")
lngName = Len(strFilename) - (Len(strExtension) + 1)
strFilename = Left(strFilename, lngName)
Do While FileExists(strPath & strFilename & Chr(46) & strExtension) = True
strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFilename & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(strFullName As String) As Boolean
'Graham Mayor
'strFullName is the name with path of the file to check
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strFullName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

[MHamid]

Hello,

The macro works perfectly in my computer. However, when I copied the macro in a co-worker's computer I get an error message in the following section of the code.


ActiveDocument.SaveAs2 FileName:=strPath & strName, _
AddToRecentFiles:=False, _
Password:=strPW, _
WritePassword:=strPW, _
ReadOnlyRecommended:=False


Why is it working in my computer, but not when I copy the code to another computer?

Thank you,
Miriam

[gmayor]

Is your co-worker using Word 2010 or later? SaveAs2 was introduced with Word 2010. For Word 2007 you would need
ActiveDocument.SaveAs FileName:=strPath & strName, _
AddToRecentFiles:=False, _
Password:=strPW, _
WritePassword:=strPW, _
ReadOnlyRecommended:=False This would work for the later versions also in this instance.

[MHamid]

Yes, my coworker is using Word 2010. So the macro should work without any issues.