在Word中使用VBA标记文档中的特殊字符

我完全不知道如何更好地处理这个过程

下面的宏分析文档中的每个字符，如果ASCII值大于255，它将对其应用特殊的字符样式-一些用于特定语言，如果不是这些语言的一部分，则仅使用“lang”

宏可以很好地工作，但是对于长文档，处理它需要很长时间。例如，我刚刚处理了一个147页（单行距）的文档，每页上有几行希腊语，用Word 2016 For Windows，它花了40分钟（相比之下，完全相同的文件和相同的代码在Mac上花了2分钟）

我可以对下面的代码做些什么来优化Windows

谢谢你的建议。 约翰

子检查特殊字符（）
'此宏查找255以上的任何字符，并用适当的现有语言字符标记它们。
Dim ch As范围：设置ch=ActiveDocument.Characters（1）
做
计数器=计数器+1
中国选择
myValue=AscW（Selection.Text）
如果myValue>255，则
如果（myValue>8190且myValue<8225）或（myValue>288且myValue<381）或（myValue>701且myValue<704）或myValue=730，则
'忽略卷引号和音译标点符号
ElseIf（myValue>7935，myValue<8192）或（myValue>879，myValue<1024），然后
“希腊字符被应用了langgrk
选择.展开单位：=wdWord
Selection.Style=“langgrk”
ElseIf（myValue>1423，myValue<1535），然后
'希伯来文字符得到langheb应用
选择.展开单位：=wdWord
Selection.Style=“langheb”
如果myValue>7679且myValue<7830
'扩展音译字符得到langtrans应用//旧值//（myValue>288和myValue<381）或（myValue>701和myValue<704）
如果HCCP=True，则选择.展开单位：=wdWord
Selection.Style=“langtrans”
ElseIf（myValue>19968，myValue<40959）然后
"汉字应用朗琴"
选择.展开单位：=wdWord
Selection.Style=“langchin”
ElseIf（myValue>19968，myValue<40917）然后
"日文角色申请朗日文"
选择.展开单位：=wdWord
Selection.Style=“langjap”
其他的
如果HCCP=True，则选择.展开单位：=wdWord
Selection.Style=“lang”
如果结束
如果结束
DoNext：
端接头

由于某些原因，我的Word（2007）版本似乎不起作用，但这可能是需要研究的内容，而不是检查字符代码

加快Office VBA宏速度的一般方法是禁用屏幕更新：

Application.ScreenUpdating = False
' some slow code that causes the screen to be updated
Application.ScreenUpdating = True 

这对您的情况应该有点帮助，因为您使用的是较慢的

选择

，而不是

范围

此外，直接检查字节值似乎比AscW快一点：

Sub test()
    'Options.DefaultHighlightColorIndex = wdNoHighlight
    'Range.HighlightColorIndex = wdNoHighlight ' used for testing to clear Highlight

    Dim r As Range, t As Double: t = Timer
    Application.ScreenUpdating = False

    For Each r In Range.Characters ' For Each r In Range.Words is somehow about 2 times slower than .Characters
        checkRange r
    Next

    Application.ScreenUpdating = True
    Debug.Print Timer - t; Range.Words.Count; Range.Characters.Count; Range.End ' " 3.15625  8801  20601  20601 "
End Sub

Sub checkRange(r As Range)
    Dim b() As Byte, i As Long, a As Long
    b = r.Text ' converts the string to byte array (2 or 4 bytes per character)
    'Debug.Print "'" & r & "'"; r.LanguageID; r.LanguageIDFarEast; r.LanguageIDOther

    For i = 1 To UBound(b) Step 2            ' 2 bytes per Unicode codepoint
        If b(i) > 0 Then                     ' if AscW > 255
            a = b(i): a = a * 256 + b(i - 1) ' AscW
            Select Case a
                Case &H1F00 To &H1FFF: r.HighlightColorIndex = wdBlue: Exit Sub ' Greek Extended
                Case &H3040 To &H30FF: r.HighlightColorIndex = wdPink: Exit Sub ' Hiragana and Katakana
                Case &H4E00 To 40959: r.HighlightColorIndex = wdGreen: Exit Sub ' CJK Unified Ideographs

                Case 55296 To 56319: ' ignore leading High Surrogates ?
                Case 56320 To 57343: ' ignore trailing Low Surrogates ?

                Case Else: r.HighlightColorIndex = wdRed: Debug.Print Hex(a), r.End - r.Start ' other
            End Select
        End If
    Next
End Sub

代码中的一些Unicode代码点（如

8190

）似乎有点不对劲，因此您可以在

---

查找并替换为格式化链接中的方法不是我需要的，因为它假定您已经知道要查找的字符。我试图识别文档中使用的任何特殊字符。如果它属于某些常见的范围，我会标记特定的语言，但其他任何被识别的语言都会应用通用的字符样式。谢谢。我将对此进行测试并让您知道。我原本禁用屏幕更新，但它并没有加速这一点，当人们看到空白屏幕这么长时间，他们认为它已经崩溃。所以我想让他们看到发生了什么总比什么都没有好。谢谢@Slai。您的方法在Windows上的效率要高得多-从40分钟减少到4分钟！（奇怪的是，这个版本在Mac上速度非常慢，所以我只保留了我在Mac上的旧方法。）@johnwangel 4分钟对我来说有点慢，因为在我的测试中，它在3秒内完成了10页。除了案件陈述之外，你还做了什么改变吗？事实上，没关系，因为我的测试只是改变了重点，而不是样式。这是一本35000字的书。

Sub test()
    'Options.DefaultHighlightColorIndex = wdNoHighlight
    'Range.HighlightColorIndex = wdNoHighlight ' used for testing to clear Highlight

    Dim r As Range, t As Double: t = Timer
    Application.ScreenUpdating = False

    For Each r In Range.Characters ' For Each r In Range.Words is somehow about 2 times slower than .Characters
        checkRange r
    Next

    Application.ScreenUpdating = True
    Debug.Print Timer - t; Range.Words.Count; Range.Characters.Count; Range.End ' " 3.15625  8801  20601  20601 "
End Sub

Sub checkRange(r As Range)
    Dim b() As Byte, i As Long, a As Long
    b = r.Text ' converts the string to byte array (2 or 4 bytes per character)
    'Debug.Print "'" & r & "'"; r.LanguageID; r.LanguageIDFarEast; r.LanguageIDOther

    For i = 1 To UBound(b) Step 2            ' 2 bytes per Unicode codepoint
        If b(i) > 0 Then                     ' if AscW > 255
            a = b(i): a = a * 256 + b(i - 1) ' AscW
            Select Case a
                Case &H1F00 To &H1FFF: r.HighlightColorIndex = wdBlue: Exit Sub ' Greek Extended
                Case &H3040 To &H30FF: r.HighlightColorIndex = wdPink: Exit Sub ' Hiragana and Katakana
                Case &H4E00 To 40959: r.HighlightColorIndex = wdGreen: Exit Sub ' CJK Unified Ideographs

                Case 55296 To 56319: ' ignore leading High Surrogates ?
                Case 56320 To 57343: ' ignore trailing Low Surrogates ?

                Case Else: r.HighlightColorIndex = wdRed: Debug.Print Hex(a), r.End - r.Start ' other
            End Select
        End If
    Next
End Sub