求问如何批量修改文件夹下所有word中有下划线的字体

rongbinlbx

文件夹下有很多个word文件，里面带下划线的字体都错了，要把它们全部改成仿宋GB_2312。要怎样写代码才行呢？

shenjianrong163

运行“Selected_Folder()”选择文件夹：

1. Sub Selected_Folder()
   
2.     Dim FN As String, myPath$, fso As Object, i#, w$, j%
   
3.     '微软Excel VBA 默认选择文件夹的Dialog对话框
   
4.     With Application.FileDialog(msoFileDialogFolderPicker) '运行后出现标准的选择文件夹对话框
   
5.         If .Show Then myPath = .SelectedItems(1) Else Exit Sub '如选中则返回=-1 / 取消未选则返回=0
   
6.     End With
   
7.     If Right(myPath, 1) <> "" Then myPath = myPath & ""
   
8.     Call ListAllFso(myPath)
   
9.     MsgBox "操作完成!", 0 + 64
   
10. End Sub
    
11. Function ListAllFso(myPath$) '用FSO方法遍历并列出所有文件和文件夹名的【递归过程】
    
12.     Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    
13.     '用FSO方法得到当前路径的文件夹对象实例 注意这里的【当前路径myPath是个递归变量】
    
14.     If Right(myPath, 1) <> "" Then myPath = myPath & ""
    
15.     FN = Dir(myPath & "*.doc*") '循环所选择文件夹目录下各个文件
    
16.     Do While FN <> "" '当文件名不为空时持续循环
    
17. '        If InStr(FN, "*.doc*") > 0 Then
    
18.             With Documents.Open(myPath & FN)
    
19.                 Call ReplaceFonts
    
20.                 .Close True
    
21.             End With
    
22. '        End If
    
23.         FN = Dir '循环到下一个文件
    
24.     Loop
    
25.     For Each fd In fld.SubFolders  '遍历当前文件夹内所有【子文件夹.SubFolders】
    
26.         Call ListAllFso(fd.Path)   '注意此时的路径变量已经改变为【子文件夹的路径fd.Path】
    
27.         '注意重点在这里： 继续向下调用递归过程【遍历子文件夹内所有文件文件夹对象】
    
28.     Next
    
29. End Function
    
30. 
    
31. Sub ReplaceFonts() '替换Word中下划线内容的字体
    
32.     Dim s$
    
33.     With ActiveDocument.Content
    
34.         With .Find
    
35.             .ClearFormatting
    
36.             .Text = ""
    
37.             .Font.Underline = wdUnderlineSingle '查找下划线
    
38.             .Replacement.Text = ""
    
39.             .Forward = True
    
40.             .MatchWildcards = False
    
41.             Do While .Execute
    
42.                 With .Parent
    
43.                     .Font.Name = "仿宋GB_2312"
    
44. '                    .Font.Underline = wdUnderlineNone '取消下划线
    
45.                     .Start = .End
    
46.                 End With
    
47.             Loop
    
48.         End With
    
49.     End With
    
50. End Sub
    

复制代码

shenjianrong163

附件供参考：




test.rar (14.23 KB, 下载次数: 4)

2021-4-16 20:24 上传

点击文件名下载附件

413191246se

* 沈老师 厉害！在我的《自动排版宏》中也有 各位老师 写的 循环遍历文件夹及子文件夹的代码。
* 仿宋字体的名称应该是：“仿宋_GB2312”，这是 WinXP 系统下应用 Office2003 所应用的字体。

shenjianrong163

413191246se 发表于 2021-4-17 01:35
* 沈老师 厉害！在我的《自动排版宏》中也有 各位老师 写的 循环遍历文件夹及子文件夹的代码。
* 仿宋字体 ...

谢谢指正！

rongbinlbx

感谢指导，非常有用