VBA : 从多个文档中删除已知密码（改进代码）
VBA : Remove know password from multiple documents (improve code)
我们公司的标志已经改变了。我们有超过 5000 个模板（.doc、.docx、.dotx、.xlsx 等）
有些文档受 pw 保护，有些则没有。
我之前的一位前同事创建了这些（此人不再在公司活跃）
因此，我已经“创建”了半可用的 VBA 代码。
这部分对于所有 3 个宏都是相同的。 （仅调用更改）
Sub RemovePassword()
Dim strPath As String
Dim strFile As String
Dim doc As Document
On Error GoTo ErrHandler
'Batch process to go through all files in a selected folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder with Word documents"
If .Show = False Then
MsgBox "You didn't select a folder.", vbInformation
Exit Sub
End If
strPath = .SelectedItems(1)
End With
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
Application.ScreenUpdating = False
strFile = Dir(strPath & "*.doc")
Do While strFile <> ""
Set doc = Documents.Open(strPath & strFile)
'Call Macro (code) to process (replace only the name)
Call RemovePwd
strFile = Dir
doc.Save
doc.Close
Loop
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
End Sub
Sub RemovePwd()
'Remove existing Pwd
ActiveDocument.Unprotect Password:="Password" *'not the real pw'*
End Sub
这个删除选定文件夹中 .doc 文档的密码（代码有效）
这段代码有 2 个问题。
- 当文档不受密码保护时，此宏会跳过所选文件夹中的所有文档。因此，文档保持锁定状态。
我必须找到所有未受保护的手动将它们从文件夹中删除或为它们添加保护。
能否调整代码，以便当文档没有密码时跳过该文档并继续下一个文档？
- 是否可以调整代码，使 Word and/or Excel.
的所有扩展都发生这种情况
其他2个宏
删除旧徽标
Sub RemoveOldLogo()
Dim hdr As HeaderFooter
Dim sec As Section
Dim sh As Shape
'Loop through all existing headers in document
For Each sec In ActiveDocument.Sections
For Each hdr In sec.Headers
Set rng = hdr.Range
For Each sh In hdr.Shapes
'Delete found Logo
sh.Delete
Next sh
Next hdr
Next sec
End Sub
添加新徽标
Sub AddNewLogo()
'Copy Logo from Master template
ChangeFileOpenDirectory "C:\MASTER_TEMPLATE\"
Documents.Open FileName:= _
"C:\MASTER_TEMPLATE\MASTER_Logo.doc", _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto, XMLTransform:=""
ActiveWindow.ActivePane.View.SeekView = wdSeekFirstPageHeader
Selection.WholeStory
Selection.Copy
ActiveWindow.Close
'Paste Logo
ActiveWindow.ActivePane.View.SeekView = wdSeekFirstPageHeader
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
所有这些宏与下面的宏
组合成运行
Sub RunAllMacros()
RemovePassword
RemoveOldLogo
AddNewLogo
End Sub
就像我说的，这些代码在文件夹中的 1 个文档不受 pw 保护时除外，它不会将其从该文件夹中具有 pw 的其他文档中删除。
如果有人对如何执行此操作有更好的解决方案，也欢迎提供信息！
我对VBA等方面的经验不是很多，这些都是在网上找到的，根据不同的代码进行调整和组合。
谢谢
氪,
蒂埃里
您遇到的主要问题是，如果您尝试取消对没有保护的文档的保护，Word 会引发 运行时间错误。此外，我建议您删除 On Error GoTo ErrHandler 语句（因为最好让 VBA 运行 时间向您显示发生错误的确切语句）。
对取消保护的例程做一个简单的更改：首先检查文档是否有保护。我建议您将文档作为参数传递，这样您就不会依赖 ActiveDocument（您需要将调用更改为 Call RemovePwd(doc)（或者只是 RemovePwd doc意思完全一样)
Sub RemovePwd(doc as Document)
If doc.ProtectionType <> wdNoProtection Then
'Remove existing Pwd
doc.Unprotect Password:="Password" *'not the real pw'*
End If
End Sub
对于Excel，顺便说一句，不需要这个检查，你可以对没有运行时间错误的未受保护的工作簿发出unprotect。
要获取所有 Word 文档，请将 Dir-命令更改为
strFile = Dir(strPath & "*.do*")
这应该找到所有 doc、docx、docm、dotx ...
您似乎在循环遍历一组文件。只做一次会更有效率。
您还可以在单个操作中替换 header，而无需先删除 header。您的代码实际上删除了文档每个部分中所有三种类型的 header，但仅替换了单个部分中的单个 header。下面更新的代码只替换了一个 header。您需要检查您的文档是否包含多个 header 并相应地编辑代码。
如果在代码中添加行号，则可以使错误处理提供更多信息。然后就可以用Erl来报告是哪一行出错了。
Sub ChangeDocumentHeaders()
Dim strPath As String
Dim strFile As String
Dim doc As Document
Dim masterLogo As Document
10 On Error GoTo ErrHandler
'Batch process to go through all files in a selected folder
20 With Application.FileDialog(msoFileDialogFolderPicker)
30 .Title = "Select a folder with Word documents"
40 If .Show = False Then
50 MsgBox "You didn't select a folder.", vbInformation
60 Exit Sub
70 End If
80 strPath = .SelectedItems(1)
90 End With
100 If Right(strPath, 1) <> "\" Then
110 strPath = strPath & "\"
120 End If
130 Set masterLogo = Documents.Open("C:\MASTER_TEMPLATE\MASTER_Logo.doc")
140 Application.ScreenUpdating = False
150 strFile = Dir(strPath & "*.do*")
160 Do While strFile <> ""
170 Set doc = Documents.Open(strPath & strFile)
'Call Macro (code) to process (replace only the name)
180 RemovePassword doc
190 ReplaceHeader doc, masterLogo
200 strFile = Dir
210 doc.Save
220 doc.Close
230 Loop
240 masterLogo.Close
250 Exit Sub
ErrHandler:
260 MsgBox "Error on line: " & Erl & vbCr & Err.Description, vbExclamation
End Sub
Sub ReplaceHeader(Target As Document, Source As Document)
Dim NewHeader As Range
Set NewHeader = Source.Sections(1).Headers(wdHeaderFooterPrimary).Range
With Target.Sections(1).Headers(wdHeaderFooterPrimary).Range
.FormattedText = NewHeader.FormattedText
'replacing header may leave an extra empty paragraph, so remove it
With .Paragraphs.Last.Range
If Len(.Text) = 1 Then .Delete
End With
End With
End Sub
Sub RemovePassword(doc As Document)
If doc.ProtectionType <> wdNoProtection Then
'Remove existing Pwd
doc.Unprotect Password:="Password"
End If
End Sub
我们公司的标志已经改变了。我们有超过 5000 个模板（.doc、.docx、.dotx、.xlsx 等） 有些文档受 pw 保护，有些则没有。
我之前的一位前同事创建了这些（此人不再在公司活跃）
因此，我已经“创建”了半可用的 VBA 代码。 这部分对于所有 3 个宏都是相同的。 （仅调用更改）
Sub RemovePassword()
Dim strPath As String
Dim strFile As String
Dim doc As Document
On Error GoTo ErrHandler
'Batch process to go through all files in a selected folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder with Word documents"
If .Show = False Then
MsgBox "You didn't select a folder.", vbInformation
Exit Sub
End If
strPath = .SelectedItems(1)
End With
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
Application.ScreenUpdating = False
strFile = Dir(strPath & "*.doc")
Do While strFile <> ""
Set doc = Documents.Open(strPath & strFile)
'Call Macro (code) to process (replace only the name)
Call RemovePwd
strFile = Dir
doc.Save
doc.Close
Loop
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
End Sub
Sub RemovePwd()
'Remove existing Pwd
ActiveDocument.Unprotect Password:="Password" *'not the real pw'*
End Sub
这个删除选定文件夹中 .doc 文档的密码（代码有效） 这段代码有 2 个问题。
- 当文档不受密码保护时，此宏会跳过所选文件夹中的所有文档。因此，文档保持锁定状态。 我必须找到所有未受保护的手动将它们从文件夹中删除或为它们添加保护。
能否调整代码，以便当文档没有密码时跳过该文档并继续下一个文档？
- 是否可以调整代码，使 Word and/or Excel. 的所有扩展都发生这种情况
其他2个宏
删除旧徽标
Sub RemoveOldLogo()
Dim hdr As HeaderFooter
Dim sec As Section
Dim sh As Shape
'Loop through all existing headers in document
For Each sec In ActiveDocument.Sections
For Each hdr In sec.Headers
Set rng = hdr.Range
For Each sh In hdr.Shapes
'Delete found Logo
sh.Delete
Next sh
Next hdr
Next sec
End Sub
添加新徽标
Sub AddNewLogo()
'Copy Logo from Master template
ChangeFileOpenDirectory "C:\MASTER_TEMPLATE\"
Documents.Open FileName:= _
"C:\MASTER_TEMPLATE\MASTER_Logo.doc", _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto, XMLTransform:=""
ActiveWindow.ActivePane.View.SeekView = wdSeekFirstPageHeader
Selection.WholeStory
Selection.Copy
ActiveWindow.Close
'Paste Logo
ActiveWindow.ActivePane.View.SeekView = wdSeekFirstPageHeader
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
所有这些宏与下面的宏
组合成运行Sub RunAllMacros()
RemovePassword
RemoveOldLogo
AddNewLogo
End Sub
就像我说的，这些代码在文件夹中的 1 个文档不受 pw 保护时除外，它不会将其从该文件夹中具有 pw 的其他文档中删除。
如果有人对如何执行此操作有更好的解决方案，也欢迎提供信息！
我对VBA等方面的经验不是很多，这些都是在网上找到的，根据不同的代码进行调整和组合。
谢谢
氪, 蒂埃里
您遇到的主要问题是，如果您尝试取消对没有保护的文档的保护，Word 会引发 运行时间错误。此外，我建议您删除 On Error GoTo ErrHandler 语句（因为最好让 VBA 运行 时间向您显示发生错误的确切语句）。
对取消保护的例程做一个简单的更改：首先检查文档是否有保护。我建议您将文档作为参数传递，这样您就不会依赖 ActiveDocument（您需要将调用更改为 Call RemovePwd(doc)（或者只是 RemovePwd doc意思完全一样)
Sub RemovePwd(doc as Document)
If doc.ProtectionType <> wdNoProtection Then
'Remove existing Pwd
doc.Unprotect Password:="Password" *'not the real pw'*
End If
End Sub
对于Excel，顺便说一句，不需要这个检查，你可以对没有运行时间错误的未受保护的工作簿发出unprotect。
要获取所有 Word 文档，请将 Dir-命令更改为
strFile = Dir(strPath & "*.do*")
这应该找到所有 doc、docx、docm、dotx ...
您似乎在循环遍历一组文件。只做一次会更有效率。
您还可以在单个操作中替换 header，而无需先删除 header。您的代码实际上删除了文档每个部分中所有三种类型的 header，但仅替换了单个部分中的单个 header。下面更新的代码只替换了一个 header。您需要检查您的文档是否包含多个 header 并相应地编辑代码。
如果在代码中添加行号，则可以使错误处理提供更多信息。然后就可以用Erl来报告是哪一行出错了。
Sub ChangeDocumentHeaders()
Dim strPath As String
Dim strFile As String
Dim doc As Document
Dim masterLogo As Document
10 On Error GoTo ErrHandler
'Batch process to go through all files in a selected folder
20 With Application.FileDialog(msoFileDialogFolderPicker)
30 .Title = "Select a folder with Word documents"
40 If .Show = False Then
50 MsgBox "You didn't select a folder.", vbInformation
60 Exit Sub
70 End If
80 strPath = .SelectedItems(1)
90 End With
100 If Right(strPath, 1) <> "\" Then
110 strPath = strPath & "\"
120 End If
130 Set masterLogo = Documents.Open("C:\MASTER_TEMPLATE\MASTER_Logo.doc")
140 Application.ScreenUpdating = False
150 strFile = Dir(strPath & "*.do*")
160 Do While strFile <> ""
170 Set doc = Documents.Open(strPath & strFile)
'Call Macro (code) to process (replace only the name)
180 RemovePassword doc
190 ReplaceHeader doc, masterLogo
200 strFile = Dir
210 doc.Save
220 doc.Close
230 Loop
240 masterLogo.Close
250 Exit Sub
ErrHandler:
260 MsgBox "Error on line: " & Erl & vbCr & Err.Description, vbExclamation
End Sub
Sub ReplaceHeader(Target As Document, Source As Document)
Dim NewHeader As Range
Set NewHeader = Source.Sections(1).Headers(wdHeaderFooterPrimary).Range
With Target.Sections(1).Headers(wdHeaderFooterPrimary).Range
.FormattedText = NewHeader.FormattedText
'replacing header may leave an extra empty paragraph, so remove it
With .Paragraphs.Last.Range
If Len(.Text) = 1 Then .Delete
End With
End With
End Sub
Sub RemovePassword(doc As Document)
If doc.ProtectionType <> wdNoProtection Then
'Remove existing Pwd
doc.Unprotect Password:="Password"
End If
End Sub