上W份WORD文档有编辑保护口令，如何批量解除这些口令

usoler

有上W份的WORD文档，但这些文档中都设置了编辑保护口令，通过网上找的一些工具只能一个文件一个文件地解除，请问哪位大神有批量处理的方法或工具？非常感谢。

比如：我的文件所在的路径为：C:\Users\usoler\Desktop\测试      （里面还有子目录）
编辑限制口令为：1111

我根据网上的说明：
打开一个WORD，ALT+F11，打开VB编辑器，增加模块，填写如下信息（比如我在附件中的 3.doc文件里添加后保存）：
Option Explicit

Sub UnProtectAllDocFiles()

    On Error Resume Next

    Const strRootPath = "C:\Users\usoler\Desktop\测试\"     ' 存放所有文件的目录，可以有子目录

    Dim fso, oFolder

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fso.GetFolder(strRootPath)
    UnProtectDocFilesUnderFolder oFolder

    MsgBox "完成！"

End Sub

Sub UnProtectDocFilesUnderFolder(oFolder)
   
    On Error Resume Next
   
    Dim oSubFolder, oFile
    Dim oDoc As Document
    Const strPassword = "1111"     ' 统一的密码

    For Each oSubFolder In oFolder.SubFolders
        UnProtectDocFilesUnderFolder oSubFolder

        For Each oFile In oSubFolder.Files
            Set oDoc = Documents.Open(FileName:=oFile.Path)
            oDoc.Unprotect strPassword
            oDoc.Close True
        Next
    Next
End Sub
保存后，点击F5进行执行，系统提示我“完成”，但是对WORD文档进行查看时，编辑限制保护口令还是存在。

解决后的方法一的代码（部分）（具体查看第12楼）：Private Sub CommandButton1_Click()
    Dim Jm As New Bej, pa$, pt$, fi$
    Dim arr$(), n%, oDoc As Document
    Const Pas = "1111": fi = "*.doc*"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = wdAlertsNone
    pa = ThisDocument.Path & "\"
    pt = ThisDocument.FullName
    arr = Jm.wwj(pa, pt, fi)
    On Error Resume Next
    Do While arr(n + 1, 1) <> ""
        n = n + 1
        Set oDoc = GetObject(arr(n, 1))
        oDoc.Unprotect Pas
        oDoc.Close -1
    Loop
    Application.DisplayAlerts = wdAlertsAll
    Application.ScreenUpdating = True
    MsgBox "解密完成！"
End Sub

解决后方法二的代码（具体查看第10楼）：
Option Explicit

Sub UnProtectAllDocFiles()
Dim oSubFolder, oFile, oDoc
On Error Resume Next
Const strRootPath = "C:\Users\usoler\Desktop\测试"
Const strPassword = "1111"
Dim msg, fso, oFolder
msg = MsgBox("是否处理子目录下文档？", vbYesNo, "选择按钮。。。")
Debug.Print msg
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(strRootPath)
For Each oFile In oFolder.Files
Set oDoc = Documents.Open(FileName:=oFile.Path)
oDoc.Unprotect strPassword
oDoc.Close True
Next
If msg = 6 Then
UnProtectDocFilesUnderFolder oFolder, strPassword
End If
MsgBox "完成！"
End Sub

Sub UnProtectDocFilesUnderFolder(oFolder, strPassword)
On Error Resume Next
Dim oSubFolder, oFile
Dim oDoc As Document
For Each oSubFolder In oFolder.SubFolders
For Each oFile In oSubFolder.Files
Set oDoc = Documents.Open(FileName:=oFile.Path)
oDoc.Unprotect strPassword
oDoc.Close True
Next
Next
End Sub

duquancai

上万啊！害怕了。话说这些文件在一个文件夹呢？还是在不同的子文件夹呢？还是算了，太多了，不玩了。

usoler

duquancai 发表于 2016-10-25 19:38
上万啊！害怕了。话说这些文件在一个文件夹呢？还是在不同的子文件夹呢？还是算了，太多了，不玩了。

是在同一个大文件夹下，然后里面有子文件夹。

usoler

duquancai 发表于 2016-10-25 19:38
上万啊！害怕了。话说这些文件在一个文件夹呢？还是在不同的子文件夹呢？还是算了，太多了，不玩了。

别啊，大神，帮帮小弟吧
在网上找的要么是单个文件的，要么是可以批量处理的但是是把密码和路径写死的（路径和密码不是我这边的情况的）执行程序（VB），真不知道怎么办了

usoler

duquancai 发表于 2016-10-25 19:38
上万啊！害怕了。话说这些文件在一个文件夹呢？还是在不同的子文件夹呢？还是算了，太多了，不玩了。

说是用这种方法可以破解，但是我试了却没有成功，也不知道是哪里的问题：
Option Explicit

Sub UnProtectAllDocFiles()

    On Error Resume Next

    Const strRootPath = "c:\Temp\docs\Help\BatchUnprotect\"     ' 存放所有文件的目录，可以有子目录

    Dim fso, oFolder

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fso.GetFolder(strRootPath)
    UnProtectDocFilesUnderFolder oFolder

    MsgBox "完成！"

End Sub

Sub UnProtectDocFilesUnderFolder(oFolder)
   
    On Error Resume Next
   
    Dim oSubFolder, oFile
    Dim oDoc As Document
    Const strPassword = "password"     ' 统一的密码

    For Each oSubFolder In oFolder.SubFolders
        UnProtectDocFilesUnderFolder oSubFolder

        For Each oFile In oSubFolder.Files
            Set oDoc = Documents.Open(FileName:=oFile.Path)
            oDoc.Unprotect strPassword
            oDoc.Close True
        Next
    Next
End Sub

kqbt

usoler 发表于 2016-10-26 10:14
说是用这种方法可以破解，但是我试了却没有成功，也不知道是哪里的问题：
Option Explicit

初略看了一下代码，应该是适用于2级以内目录。
另外，有几处是要改成你自己的数据（不知道你改了没有）：
Const strRootPath = "c:\Temp\docs\Help\BatchUnprotect\"
Const strPassword = "password"

usoler

kqbt 发表于 2016-10-26 10:23
初略看了一下代码，应该是适用于2级以内目录。
另外，有几处是要改成你自己的数据（不知道你改了没有） ...

目前我测试的是目录只有根目录，相关路径和密码修改的是我自己的，但是也没有成功。

duquancai

usoler 发表于 2016-10-26 11:32
目前我测试的是目录只有根目录，相关路径和密码修改的是我自己的，但是也没有成功。

你这样空谈，永远也没结果，附件模拟

usoler

duquancai 发表于 2016-10-26 13:48
你这样空谈，永远也没结果，附件模拟

我已经将我进行测试的附件及相关操作进行了上传及说明，请大神帮忙给看下，是哪里出现了问题，谢谢了。

kqbt

usoler 发表于 2016-10-26 11:32
目前我测试的是目录只有根目录，相关路径和密码修改的是我自己的，但是也没有成功。

稍作修改，可测试是否适用于所选目录及下一级其子目录：

1. Sub UnProtectAllDocFiles()
   
2. On Error Resume Next
   
3. Const strRootPath = "指定的目录"
   
4. Const strPassword = "解除保护密码"
   
5. Dim msg, fso, oFolder
   
6. msg = MsgBox("是否处理子目录下文档？", vbYesNo, "选择按钮。。。")
   
7. Debug.Print msg
   
8. Set fso = CreateObject("Scripting.FileSystemObject")
   
9. Set oFolder = fso.GetFolder(strRootPath)
   
10. For Each oFile In oFolder.Files
    
11. Set oDoc = Documents.Open(FileName:=oFile.Path)
    
12. oDoc.Unprotect strPassword
    
13. oDoc.Close True
    
14. Next
    
15. If msg = 6 Then
    
16. UnProtectDocFilesUnderFolder oFolder, strPassword
    
17. End If
    
18. MsgBox "完成！"
    
19. End Sub
    
20. 
    
21. Sub UnProtectDocFilesUnderFolder(oFolder, strPassword)
    
22. On Error Resume Next
    
23. Dim oSubFolder, oFile
    
24. Dim oDoc As Document
    
25. For Each oSubFolder In oFolder.SubFolders
    
26. For Each oFile In oSubFolder.Files
    
27. Set oDoc = Documents.Open(FileName:=oFile.Path)
    
28. oDoc.Unprotect strPassword
    
29. oDoc.Close True
    
30. Next
    
31. Next
    
32. End Sub

复制代码