自动标注音标

 

 

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub GetPhonetic()

'必须有音标字体安装Kingsoft Phonetic Plain

'写在前面:您运行此程序前必须引用MSForms

'即VBE/工具/引用:Microsoft Forms 2.0 Object Library (C:\WINNT\system32\FM20.DLL)

'打开金山词霸,并使用显示在任务栏中,不是最小化系统托盘(启动栏)中!!(金山词霸/主菜单/

'设置/界面方案/其它/其它选项:任务栏图标,去勾)并关闭屏幕取词功能!

'将每个单词为一个段落,注意,本程序未加入单词拼写检查,可在WORD中拼写和语法检查中设置

    On Error Resume Next

    

    Dim translator As String

    translator = "金山词霸2007（暂停取词）"

    If Tasks.Exists(translator) = False Then Exit Sub    '如果未在任务栏中则关闭程序

    

    'Application.ScreenUpdating = False    '关闭屏幕更新

    With ActiveDocument

        Dim i As Paragraph

        For Each i In .Paragraphs    '在段落中循环

            i.Range.Select

            

            Dim EwTxt As String

            EwTxt = i.Range.Text

            EwTxt = Trim(EwTxt)

            EwTxt = VBA.Split(EwTxt, " ")(0)   '返回文本(单词)

            If Len(EwTxt) < 2 Then GoTo GN '如果为空白段落则继续下一次

            

            Tasks(translator).WindowState = wdWindowStateNormal    '正常窗口

            Tasks(translator).Activate    '激活金山词霸应用程序，此处填写金山词霸任务栏的内容，如金山词霸2007

            SendKeys EwTxt, True    '发送单词

            'Sleep 1000

            SendKeys "{TAB 2}", True    '移动二次TAB

            'Sleep 500

            SendKeys "^a", True    '复制

            'Sleep 500

            SendKeys "^c", True    '复制

            Sleep 500   '稍微停顿一下以等待以前的操作完成

            

            Dim MyData As DataObject

            Set MyData = New DataObject    '引用DataObject

            MyData.GetFromClipboard    '从剪贴板复制数据到 DataObject

            

            Dim CopyTxt As String

            CopyTxt = MyData.GetText(1)    '获得无格式文本

            

            Dim Mystring() As String

            Mystring = VBA.Split(CopyTxt, vbCrLf)    '返回一个数组

            

            Dim aString As String

            aString = Mystring(1)    '取得数组中的第二个值,也就是音标

            

            Dim StartWrite As Long

            StartWrite = i.Range.End - 1    '取得段落标记前的位置

           

            Dim MyRange As Range

            Set MyRange = .Range(StartWrite, StartWrite)    '取得段落标记前的插入点区域

            

            MyRange.InsertAfter "　" & aString    '在插入点处插入音标

            '设置该区域的音标字体

            .Range(StartWrite + 2, i.Range.End - 2).Font.Name = "Kingsoft Phonetic Plain"

            

            Tasks(translator).WindowState = wdWindowStateMinimize    '正常窗口

            Tasks(VBA.Replace(.Name, ".doc", "")).Activate    '激活WORD文档

            i.Range.Select

GN:     Next

        'Application.ScreenUpdating = True    '恢复屏幕更新工作

        MsgBox "自动音标标注工作已经结束!", vbInformation + vbOKOnly, "Microsoft Word" '提示

    End With

End Sub

　　

参考：http://hi.baidu.com/zl90712/item/77c225e60816b60c8c3ea80b