VBA：从多个文档中删除已知密码改进代码

如何解决VBA：从多个文档中删除已知密码改进代码

我们公司的标志已更改。我们有超过 5000 个模板（.doc、.docx、.dotx、.xlsx 等）有些文件受密码保护，有些则没有。

我之前的一位前同事创建了这些（此人不再活跃于公司）

所以，我已经“创建”了一个半有效的 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文档的密码（代码有效）这段代码有两个问题。

当文档不受密码保护时，此宏会跳过所选文件夹中的所有文档。因此，文档保持锁定状态。我必须找到所有未受保护的文件，手动将它们从文件夹中删除，或者也为它们添加保护。

是否可以调整代码，以便在文档没有密码时跳过该文档并继续下一个文档？

是否可以调整代码，使 Word 和/或 Excel 的所有扩展程序都发生这种情况。

另外两个宏

移除旧标志

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 个文档不受密码保护时，这些代码都可以工作，它不会将其从该文件夹中具有密码的其他文档中删除。

如果有人对如何执行此操作有更好的解决方案，也欢迎提供该信息！

我对 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 ...

看起来好像您正在多次循环访问这组文件。只做一次会更有效率。

您还可以在一次操作中替换标题，而无需先删除标题。您的代码实际上删除了文档每个部分中的所有三种类型的标题，但仅替换了单个部分中的单个标题。下面的更新代码仅替换单个标题。您需要检查您的文档是否包含多个标题并相应地编辑代码。

如果您在代码中添加行号，您可以使错误处理更具信息性。然后你可以使用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

VBA：从多个文档中删除已知密码改进代码

如何解决VBA：从多个文档中删除已知密码改进代码

解决方法

相关推荐