自动标注音标升级版

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