自动标注音标

 

 

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