如何才能快速去除文件夹下所有WORD文件超链接?

413191246se

* 请 楼主 重新测试一下（备份原文件后再应用）：

1. Sub LoopFolder_gbgbxgb()
   
2.     Dim d As Object, thePath$, theStr$, i&, j&, k&, doc As Document
   
3.     thePath = SelectFolder
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     d(thePath) = ""
   
6.     Do While i < d.Count
   
7.         thePath = d.keys()(i)
   
8.         theStr = Dir(thePath, vbDirectory)
   
9.         Do While theStr <> ""
   
10.             If theStr <> "." And theStr <> ".." Then
    
11.                 If (GetAttr(thePath & theStr) And vbDirectory) = vbDirectory Then
    
12.                     d(thePath & theStr & "") = ""
    
13.                 Else
    
14.                     j = j + 1
    
15.                     If thePath & theStr Like "*.doc*" Then
    
16.                         Set doc = Documents.Open(FileName:=thePath & theStr)
    
17.                         doc.Fields.Unlink
    
18.                         doc.Close SaveChanges:=wdSaveChanges
    
19.                         k = k + 1
    
20.                     End If
    
21.                 End If
    
22.             End If
    
23.             theStr = Dir
    
24.         Loop
    
25.         i = i + 1
    
26.     Loop
    
27.     Set d = Nothing
    
28.     MsgBox "文件夹包含 " & j & " 个文件！" & i - 1 & " 个子文件夹！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & k & " 个！", 0 + 48
    
29. End Sub
    
30. Function SelectFolder() As String
    
31.     With Application.FileDialog(msoFileDialogFolderPicker)
    
32.         If .Show Then SelectFolder = .SelectedItems(1) & "" Else End
    
33.     End With
    
34.     If MsgBox("是否处理文件夹 " & """" & SelectFolder & """" & " ?", 4 + 16) = vbNo Then End
    
35. End Function

复制代码

回头浪子就是我

413191246se 发表于 2020-10-13 22:51
* 请 楼主 重新测试一下（备份原文件后再应用）：

感谢大神费心!