自动标注音标升级版

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