自動標註音標升級版

Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
'爲選擇的文本中的每一個單詞註上音標
Sub Start()
    On Error Resume Next
    
    '文檔
    Dim Document As Document
    Set Document = ActiveDocument
     
    '各個索引
    Dim currentIndex As Long, endIndex As Long
    currentIndex = Selection.Start
    endIndex = Selection.End
     
    '正則表達式，用於搜索單詞
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = "[a-z]+" '限制純英文
    End With
     
    '開始工做
    Do While currentIndex < endIndex
        '獲取餘後要比較的文本
        Dim rng As Range, text As String
        Set rng = Document.Range(currentIndex, endIndex)
        text = rng.text
         
        '匹配結果
        Dim matches As Object
        Set matches = regex.Execute(text)
        If matches.count > 0 Then
            Dim match As Object
            Set match = matches(0)
             
            '新單詞
            Dim word As String, wordStart As Long, wordEnd As Long
            word = match.Value
            wordStart = currentIndex + match.FirstIndex
            wordEnd = wordStart + match.Length
             
            '查詢
            Dim explanation As String
            If (Not Lookup(word, explanation)) Then
                Exit Do
            End If
             
            '插入
            Dim wordRng As Range
            Set wordRng = Document.Range(wordStart, wordEnd)
            wordRng.InsertAfter explanation
             
            '設置樣式
            Dim explanationRng As Range
            Set explanationRng = Document.Range(wordEnd, wordRng.End)
            explanationRng.Font.Color = RGB(0, 0, 0)
            explanationRng.HighlightColorIndex = wdGray25
            explanationRng.Font.Size = "8"
            '設置音標字體
            Dim innerRng As Range
            Set innerRng = Document.Range(wordEnd + 1, wordRng.End - 1)
            innerRng.Font.Name = "Kingsoft Phonetic Plain"
             
            '準備下一次
            currentIndex = wordRng.End
            endIndex = endIndex + Len(explanation)
        Else
            Exit Do
        End If
    Loop
End Sub
 
Function Lookup(word As String, ByRef explanation As String) As Boolean
    Lookup = True
 
    '確保有翻譯軟件
    Dim translator As String
    translator = "金山詞霸2007（暫停取詞）"
    If Tasks.Exists(translator) = False Then'查詢詞典軟件是否在運行中（要以管理員身份運行此VBA）
        MsgBox "請打開金山詞霸2007並將其最小化至任務欄中"
        Lookup = False
        Exit Function    '若是未在任務欄中則關閉程序
    End If
 
    '查詢單詞
    Tasks(translator).WindowState = wdWindowStateNormal    '正常窗口
    Tasks(translator).Activate    '激活金山詞霸應用程序，此處填寫金山詞霸任務欄的內容，如金山詞霸2007
    SendKeys word, True    '發送單詞
    'Sleep 1000
    SendKeys "{TAB 2}", True    '移動二次TAB
    'Sleep 500
    SendKeys "^a", True    '複製
    'Sleep 500
    SendKeys "^c", True    '複製
    Sleep 800   '稍微停頓一下以等待之前的操做完成
 
    '獲取查詢結果
    Dim MyData As MSForms.DataObject
    Set MyData = New MSForms.DataObject    '引用DataObject(隨便拖一個窗體控件進來即可以引入其DLL)
    MyData.GetFromClipboard    '從剪貼板複製數據到 DataObject
 
    Dim CopyTxt As String
    CopyTxt = MyData.GetText(1)    '得到無格式文本
      
    Dim Mystring() As String
    Mystring = VBA.Split(CopyTxt, vbCrLf)    '返回一個數組
 
    explanation = Mystring(1)    '取得數組中的第二個值,也就是音標
 
    '最小化翻譯軟件
    Tasks(translator).WindowState = wdWindowStateMinimize
    
    '成功
    Lookup = True
End Function