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

Question

我完全丧失了处理此过程的更好方法。

以下宏分析文档中的每个字符，并且如果ASCII值高于255，它将对其应用特殊字符样式 - 有些针对特定语言，或者只是针对特定语言的“lang”，如果它不是这些字符的一部分语言。

该宏可以很好地工作，但在长文档中，需要花费很长的时间来处理。例如，我刚刚在每个页面上处理了一个147页（单间隔）的文档，其中包含几行希腊文，花了40分钟，在Word 2016 for Windows中（相反，完全相同的文件和相同的代码需要2分钟在Mac上）。

有什么我可以做的下面的代码来优化这个Windows？

感谢您的任何建议。 约翰

Sub CheckSpecialCharacters() 
    'This macro looks for any characters above 255 and tags them with the appropriate existing language character. 

     Dim ch As Range: Set ch = ActiveDocument.Characters(1) 

     Do 

      Counter = Counter + 1 

      ch.Select 

      myValue = AscW(Selection.Text) 
      If myValue > 255 Then 

       If (myValue > 8190 And myValue < 8225) Or (myValue > 288 And myValue < 381) Or (myValue > 701 And myValue < 704) Or myValue = 730 Then 
        'Ignores Curly Quotes and Transliteration punctuation 

       ElseIf (myValue > 7935 And myValue < 8192) Or (myValue > 879 And myValue < 1024) Then 
        'Greek Characters get langgrk applied 
        Selection.Expand unit:=wdWord 
        Selection.Style = "langgrk" 

       ElseIf (myValue > 1423 And myValue < 1535) Then 
        'Hebrew Characters get langheb applied 
        Selection.Expand unit:=wdWord 
        Selection.Style = "langheb" 

       ElseIf myValue > 7679 And myValue < 7830 Then 
        'Extended transliteration characters get langtrans applied //OLD VALUES// (myValue > 288 And myValue < 381) Or (myValue > 701 And myValue < 704) 
        If HCCP = True Then Selection.Expand unit:=wdWord 
        Selection.Style = "langtrans" 

       ElseIf (myValue > 19968 And myValue < 40959) Then 
        'Chinese Characters get langchin applied 
        Selection.Expand unit:=wdWord 
        Selection.Style = "langchin" 

       ElseIf (myValue > 19968 And myValue < 40917) Then 
        'Japanese Characters get langjap applied 
        Selection.Expand unit:=wdWord 
        Selection.Style = "langjap" 

       Else 
        If HCCP = True Then Selection.Expand unit:=wdWord 
        Selection.Style = "lang" 

       End If 

      End If 

DoNext: 


End Sub 

Answer 1

出于某种原因Range.DetectLanguage似乎并没有对我的版本的Word（2007年）的工作，但是这可能是一个寻找到的不是检查字符编码。

的一般方法，以加快办公室VBA宏是禁用屏幕更新：

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

这将有助于你的情况一点，因为你正在使用，而不是Range较慢Selection。

此外，检查字节值直接似乎有点比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 

很少在你的代码一样8190 Unicode码点似乎有点过了，这样你就可以在 http://www.fileformat.info/info/unicode/block/index.htm

检查他们