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