一个自动标注单词音标的小程序

守柔

运行此程序前,必须手动打开金山词霸,并使其处于任务栏中,而非最小化到系统托盘里!!
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ 2005-2-25 08:09:09
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub GetPhonetic()
'写在前面:您运行此程序前必须引用MSForms
'即VBE/工具/引用:Microsoft Forms 2.0 Object Library (C:\WINNT\system32\FM20.DLL)
'打开金山词霸,并使用显示在任务栏中,不是最小化系统托盘(启动栏)中!!(金山词霸/主菜单/设置/界面方案/其它/其它选项:任务栏图标,去勾)并关闭屏幕取词功能!
'将每个单词为一个段落,注意,本程序未加入单词拼写检查,可在WORD中拼写和语法检查中设置
    Dim EwTxt As String, MyData As DataObject, CopyTxt As String, MyRange As Range
    Dim Mystring() As String, aString As String, i As Paragraph, StartWrite As Long
    On Error Resume Next
    If Tasks.Exists("金山词霸") = False Then Exit Sub    '如果未在任务栏中则关闭程序
    Tasks("金山词霸").WindowState = wdWindowStateNormal    '正常窗口
    Set MyData = New DataObject    '引用DataObject
    Application.ScreenUpdating = False    '关闭屏幕更新
    With ActiveDocument
        For Each i In .Paragraphs    '在段落中循环
            If Len(i.Range) = 1 Then GoTo GN    '如果为空白段落则继续下一次
            EwTxt = i.Range.Text    '返回文本(单词)
            StartWrite = i.Range.End - 1    '取得段落标记前的位置
            Set MyRange = .Range(StartWrite, StartWrite)    '取得段落标记前的插入点区域
            Tasks("金山词霸").Activate    '激活金山词霸应用程序
            SendKeys EwTxt, True    '发送单词
            SendKeys "{TAB 2}", True    '移动二次TAB
            SendKeys "^c", True    '复制
            MyData.GetFromClipboard    '从剪贴板复制数据到 DataObject
            CopyTxt = MyData.GetText(1)    '获得无格式文本
            Mystring = VBA.Split(CopyTxt, vbCrLf)    '返回一个数组
            aString = Mystring(1)    '取得数组中的第二个值,也就是音标
            MyRange.InsertAfter "　" & aString    '在插入点处插入音标
            '设置该区域的音标字体
            .Range(StartWrite + 2, i.Range.End - 2).Font.Name = "Kingsoft Phonetic Plain"
GN:             Next
        Application.ScreenUpdating = True    '恢复屏幕更新工作
        Tasks(VBA.Replace(.Name, ".doc", "")).Activate    '激活WORD文档
        '提示
        MsgBox "自动音标标注工作已经结束!", vbInformation + vbOKOnly, "Microsoft Word"
    End With
End Sub
'----------------------

zz5151353

看起來是不錯的好東西,先下載收藏,說不定將來會用的到,感謝版主無私提供分享 !!!

如意

守柔的大作，一定要收藏的。

soar

看不懂，到底怎么用呢？

tangqingfu

收藏,对英语老师很有用,谢谢守版主!!!

skychow

原帖由 守柔 于 2005-2-25 09:00 发表
运行此程序前,必须手动打开金山词霸,并使其处于任务栏中,而非最小化到系统托盘里!!
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ 2005-2-25 08:09:09
'仅 ...

这个要怎么用啊，怎么也看不懂，能讲祥细点吗？小弟跪谢了！！！

danq

这个怎么用啊,请楼主解释清楚啊,要不更好的东西也是浪费啊?谢谢!自己顶顶顶顶!

danq

有没有大侠帮帮忙啊?真的很需要这个好东东啊,守柔版主我在等待你的佳音.

lclnancy2006

我先下载，慢慢消化，不懂再请教。谢谢了！

tianty1

请问怎么用啊？我也不懂啊？能否给出一个详尽操作步骤？谢谢了！

aduki

好东西先收藏了！！:em67

bfchenwj

真是应了一句俗话＂一个锅要补，一个要补锅＂，好用！

jfcat

谢了！
很实用！
:em67

foreman301

阁下是英文老师喽。。。

守柔

时间关系，我简单地测试了一下，请yds7217兄多测试一下。
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@OfficeFans 2008-4-15 6:47:06
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0396^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub GetPhonetic()
'写在前面:您运行此程序前必须引用MSForms
'即VBE/工具/引用:Microsoft Forms 2.0 Object Library (C:\WINNT\system32\FM20.DLL)
'打开金山词霸,并使用显示在任务栏中,不是最小化系统托盘(启动栏)中!!(金山词霸/主菜单/
'设置/界面方案/其它/其它选项:任务栏图标,去勾)并关闭屏幕取词功能!
'将每个单词为一个段落,注意,本程序未加入单词拼写检查,可在WORD中拼写和语法检查中设置
    Dim EwTxt As String, MyData As DataObject, CopyTxt As String, MyRange As Range
    Dim Mystring() As String, aString As String, i As Paragraph, StartWrite As Long
    Dim bString As String, cString As String
    On Error Resume Next
    If Tasks.Exists("金山词霸") = False Then Exit Sub    '如果未在任务栏中则关闭程序
    Tasks("金山词霸").WindowState = wdWindowStateNormal    '正常窗口
    Set MyData = New DataObject    '引用DataObject
    Application.ScreenUpdating = False    '关闭屏幕更新
    With ActiveDocument
        For Each i In .Paragraphs    '在段落中循环
            If Len(i.Range) = 1 Then GoTo GN    '如果为空白段落则继续下一次
            EwTxt = i.Range.Text    '返回文本(单词)
            StartWrite = i.Range.End - 1    '取得段落标记前的位置
            Set MyRange = .Range(StartWrite, StartWrite)    '取得段落标记前的插入点区域
            Tasks("金山词霸").Activate    '激活金山词霸应用程序
            SendKeys EwTxt, True    '发送单词
            SendKeys "{TAB 2}", True    '移动二次TAB
            SendKeys "^c", True    '复制
            MyData.GetFromClipboard    '从剪贴板复制数据到 DataObject
            CopyTxt = MyData.GetText(1)    '获得无格式文本
            Mystring = VBA.Split(CopyTxt, vbCrLf)    '返回一个数组
            aString = Mystring(1)    '取得数组中的第二个值,也就是音标
            MyRange.InsertAfter "　" & aString    '在插入点处插入音标
            .Range(StartWrite + 2, i.Range.End - 2).Font.Name = "Kingsoft Phonetic Plain"
            bString = Mystring(2)    '取得数组中的第三个值,也就是词性
            cString = Mystring(3)    '取得数组中的第四个值,也就是释义
            MyRange.InsertAfter "　" & bString    '在插入点处插入词性
            MyRange.InsertAfter "　" & cString    '在插入点处插入释义
            '设置该区域的音标字体
GN:             Next
        Application.ScreenUpdating = True    '恢复屏幕更新工作
        Tasks(VBA.Replace(.Name, ".doc", "")).Activate    '激活WORD文档
        '提示
        MsgBox "自动音标标注工作已经结束!", vbInformation + vbOKOnly, "Microsoft Word"
    End With
End Sub
'----------------------

天下为空

下载了，晚上试试，谢谢

tangqingfu

To 守版:
怎么使用?我已运行金山词霸了,可是运行您的代码还是没有反应呢?
用F8逐句运行代码,到这一句就停止了:
If Tasks.Exists("金山词霸") = False Then Exit Sub    '如果未在任务栏中则关闭程序

守柔

原帖由 tangqingfu 于 2008-12-31 18:57 发表
To 守版:
怎么使用?我已运行金山词霸了,可是运行您的代码还是没有反应呢?
用F8逐句运行代码,到这一句就停止了:
If Tasks.Exists("金山词霸") = False Then Exit Sub    '如果未在任务栏中则关闭程序

不同版本的“金山词霸”，其在任务栏中的名称有所不同。
运行以下InsertTaksNames过程，在当前文档中查看与金山相关程序的任务栏中的名称后相应修改即可。
Option Explicit
Public Sub InsertTaksNames()
    ActiveDocument.Content.InsertAfter GetTasks
End Sub

Private Function GetTasks() As String
    Dim oTask As Word.Task
    Dim str_Tasks As String
    For Each oTask In Word.Tasks
        str_Tasks = str_Tasks & oTask.Name & vbCrLf
    Next
    GetTasks = str_Tasks
End Function
能正确运行后，请把你的If Tasks.Exists("?") = False Then Exit Sub中的“？”值贴上来，以供后来者实习之。