用VBA设置WORD文档所有字母和数字字体

39660519

duquancai 发表于 2016-9-21 14:20

谢谢，我按照你的代码修改了，但有部分字体没有修改，你帮我看看
代码在“编写工艺规程”模块的“自动编写工艺规程”工程最后面

39660519

duquancai 发表于 2016-9-21 14:20

谢谢，我按照你的代码修改了，但有部分字体没有修改，你帮我看看
代码在“编写工艺规程”模块的“自动编写工艺规程”工程最后面

duquancai

39660519 发表于 2016-9-21 14:43
谢谢，我按照你的代码修改了，但有部分字体没有修改，你帮我看看
代码在“编写工艺规程”模块的“自动编 ...

你提供的6个word文档都修改了吧？你真实文档没修改？截图看看。现在手机没法搞

duquancai

39660519 发表于 2016-9-21 14:43
谢谢，我按照你的代码修改了，但有部分字体没有修改，你帮我看看
代码在“编写工艺规程”模块的“自动编 ...

有表格？你提供的附件可没有表格吧！！！

39660519

duquancai 发表于 2016-9-21 14:50
你提供的6个word文档都修改了吧？你真实文档没修改？截图看看。现在手机没法搞

谢谢，麻烦帮看看，我用EXCEL自动生成的工艺规程，生成后自动转换字母数字字体，有部分没有转换

Sub 自动编写工艺规程()
    Application.ScreenUpdating = False  '关平屏幕刷新
    Application.DisplayAlerts = False    '在程序执行过程中使出现的警告框不显示
    On Error Resume Next
   
    Set 正则对象 = CreateObject("VBSCRIPT.REGEXP")
    正则对象.Global = True
    正则对象.MultiLine = True
    正则对象.IgnoreCase = True
    正则对象.Pattern = "\s"
   
  ..................................................省略部分为生成文档部分
            
            正则对象.Pattern = "[0-9A-Za-z]+"
            Set Arng = WORD文件.Content
            For Each mt In 正则对象.Execute(Arng)
                m = mt.FirstIndex: n = mt.Length
                Set oRang = WORD文件.Range(m, m + n)
                oRang.Font.Name = "Times New Roman"
            Next
            
            WORD文件.SaveAs Filename:=文件  '另存为
            WORD文件.Close    '关闭文档
            If 单独行 <> "" Then
                GoTo 2
            End If
        Next B
        
2:
        .Quit      '退出Word对象
    End With
   
    MsgBox "操作完毕！"
   
    Application.DisplayAlerts = True     '在程序执行过程中显示警告框
    Application.ScreenUpdating = True    '打开屏幕刷新
End Sub

39660519

duquancai 发表于 2016-9-21 15:33
有表格？你提供的附件可没有表格吧！！！

是的，有很多表格

39660519

duquancai 发表于 2016-9-21 15:33
有表格？你提供的附件可没有表格吧！！！

我原来想利用WORD里的查找替换功能，但没成功

duquancai

39660519 发表于 2016-9-21 15:41
我原来想利用WORD里的查找替换功能，但没成功

用word的find对象可以成功，但是速度非常慢，而用正则速度很快，但是只对纯文本啊！

duquancai

39660519 发表于 2016-9-21 15:41
我原来想利用WORD里的查找替换功能，但没成功

但是速度很慢！但是包括表格中的字母及数字都可以，自己测试吧！！

1. Sub shishi()
   
2.     Dim pt$, f$, wd As Object, n&, m&, wdapp As Object
   
3.     Dim Arng As Object, oRang As Object, mt
   
4.     Application.ScreenUpdating = False
   
5.     Set wdapp = CreateObject("Word.Application")
   
6.     wdapp.Visible = False
   
7.     pt = ThisWorkbook.Path & ""
   
8.     f = Dir(pt & "*.doc*")
   
9.     Do While f <> ""
   
10.         Set wd = wdapp.Documents.Open(pt & f, Visible:=False)
    
11.         Set Arng = wd.Content
    
12.         With Arng.Find
    
13.             .Text = "[a-zA-Z0-9]{1,}"
    
14.             .MatchWildcards = True
    
15.             Do While .Execute
    
16.                 .Parent.Font.Name = "Times New Roman"
    
17.             Loop
    
18.         End With
    
19.         wd.Close True
    
20.         f = Dir
    
21.     Loop
    
22.     wdapp.Quit
    
23.     MsgBox "操作完毕！"
    
24.     Application.ScreenUpdating = True
    
25. End Sub

复制代码

39660519

duquancai 发表于 2016-9-21 15:49
用word的find对象可以成功，但是速度非常慢，而用正则速度很快，但是只对纯文本啊！

我原来“T = WORD文件.Characters(A1).Text”判断每一个字节更慢，5分钟才改完一个文件，还有什么好办法吗？