[求助]为英语生词自动生成词汇表

雨雪霏霏

感谢老大在很短的时间里就为小弟花了大量精力，拿出这样绝妙的自动词汇表方案！——老大惜乎不是女的，如果是女的，必是天下最温柔体贴的魔力女神。也正因为老大不是女的，所以，要对家园里这么多兄弟如此体贴、对小弟更是翼护，便显出老大十足的“长者之范”！水平超高，至仁至爱，笑对天下，老大可比大肚弥勒佛矣！

孔兄每每在老大接手小弟的烦杂问题之后，仍来帮忙小弟，跨千年之鸿沟风尘仆仆餐风露宿只为解小弟“危难”而来，小弟有幸至此，能不仰叹唏嘘！

无知无德小弟，二老始终不厌不弃，反愈益爱护有加，是小弟漫漫人生道上之大幸！

每次总是只有感动，言语总是不能尽意！

以下为测试报告，请二老指正：

一、老大的编码。

未在金山词霸2005中测试，小弟在金山词霸2003中测试之后，直接于金山词霸2006中测试。

1、不尽感激。

感谢老大的体贴，把小弟粗浅的想法进行了高度统筹，得着了这么样别出心裁的好程序！

以下为小弟的使用步骤，也请家园里的各位兄弟参考：

①在阅读英语文章的时候，看到生词，直接在文档中用鼠标右键点击生词；

②于右键菜单上点选第一项“××To 生词表”（注：“××”处是某个生词，它是变化着的，点甲生词就显示为甲生词，点乙生词，就是显示为乙生词）。这时，Word会自动在文档尾增添一个表格，并且为这表格加了一个表头，表格为三行四列，内容如下（以小弟点选生词的是“Application”为例）：

----------我的生词表---------

序　　　生词　　　　　　　音标　　　　　　　　释义

1　　　Application　　　　[、æpli'kei∫әn]　　　　  n.
　　　　　　　　　　　　　　　　　　　　　　　请求, 申请, 申请表, 应用, 运用, 施用, 敷用
　　　　　　　　　　　　　　　　　　　　　　　应用,应用程序,应用软件

（表格的第三行为空行）

③重复①②动作，则表格第三行加入了第二个生词，表格自动加入一个空着的第四行。

如此反复，可以加入无数单词。一篇文章看完，一个生词表也就生成了。

小结之，老大的体贴入微处有以下五方面：

A、阅读文章时，碰到生词，不需要复制生词，直接在生词上右键就可进行生成词汇表操作；

B、直接在文档尾自动生成生词表，省却了新建Word文档、逐个复制生词的麻烦。

C、自动为生词进行编号，方便查看记忆。

D、为表格加了表头与列头，一目了然。

E、不打断文章的阅读。直接在当前阅读处点右键就把生词加入了文档尾的生词表，光标并没有跑到文档尾去，呈现在眼前的仍然是当前阅读处。金山词霸界面一闪即隐，不影响视线。

2、小弟的鄙陋之想。

①、如上所示，第四列中，词性与中文释义是分作两行的，这在文档中阅读，也算比较醒目（虽然有的时候也觉得看起来不大习惯）。但如果要把生词表打印出来的话，则这样的分作两行过于浪费纸张。因此，一定要进行一次手工替换操作，把词性与中文释义合成一行（词性与中文释义，最好还要有一个半角空格分隔开）。这样，每次阅读后，都要进行一次手工操作，也仍然是比较大的工作量。

因此，请老大参考一下小弟的三楼附件中的释义那一列，再费心为小弟编程，把词性与中文释义并成一列（如上段所说，额外要求是：词性与释义中间要加入一个半角空格）。

②、和老大的自动标注音标的程序一样，对于没有音标的生词，音标所在位置不是显示为空，而是把词性提取过来，这样，音标列便不全是音标，而释义列中，又少了这个词性了。示例如下：

----------我的生词表---------

序 　　 生词 　　　　　　    音标 　　　　　释义
　　1　　　vividly　　　　　　　v. 　　　　　生动地, 鲜明地
　　2　　　depict    　　　　     ['dipikt]　　　　 vt.
　　　　　　　　　　　　　　　　　　　　 描述, 描写
　　3　　　unreasonably　　　　  v. 　　　　　不合理地
　　4　　　fruitful    　　　　     ['fru:tful] 　　　 adj.
　　　　　　　　　　　　　　　　　　　　 果实结得多的, 多产的, 富有成效的

小弟的理想：没有音标的，音标那一列为空，词性和释义仍然在同一列。

③、因为整个操作过程中，禁止了屏幕取词，所以，碰到生词的时候，无法使用金山词霸的“即时显示”与“即时发音”功能，这样，获取生词表是十分顺利了，但借助金山词霸进行长篇英语文章阅读的流畅性却大受影响。

故而，小弟的理想是：允许即时显示与即时发音，同时不影响使用老大的自动词汇表功能。

或者另外的解决方案是：

使用孔兄的方案方便地提取生词到一个新文档中（在旧文档中可以方便地借助金山词霸进行阅读长篇英语文章），再于老大以前的标注音标的程序的基础上，把整批生词自动转为生词表。——忘了跟老大说，小弟一直以来借助老大的标注音标程序，也有相当大一部分是用来批量加注音标：

网上下载来的英语单词资料中，往往提供了单词与释义，但不提供音标，利用老大以前的程序，可以为它们顺利加上音标，构成了整个完成的词汇表。

而只提供单词，不提供音标与释义的材料，也是很多的，所以，小弟也很需要有一个程序，能够为批量的生词进行一次性操作，生成词汇表。

这个问题换成另一种说法就是：

A、老大别出心裁地为小弟解决了阅读时碰到生词自动于文档尾生成词汇表的问题。小弟非常感谢老大最细致的设身处地为小弟着想（小弟还根本没想过老大这样的一种绝妙的解决方案），为小弟解决了很棘手的问题。

B、小弟仍然存在着需求——如何把成批的生词一次性转为词汇表，而不是反复使用老大现在编出的程序，一个个把生词发送到文档尾的生词表中。

二、孔兄的编码。

孔兄的小程序十分贴心可爱，让人反复玩味。小弟一用之下，便喜笑不已——有孔兄这个编码，可以免除在两个文档中频繁切换的苦恼了。谢谢孔兄为小弟之窘困渡江而来！

孔兄这个编码，适用范围极广，不仅仅是用在小弟的词汇表设想中。佩服孔兄的“神来之想”！

三、综合二老思路，小弟斗胆之想。

能否请老大在编码中参用孔兄的编码，解决小弟的问题？

即小弟的问题，根据不同的情况，自由选择应用以下两种解决方案：

A、直接使用老大现在的程序，一边阅读一边在文档尾自动加上生词表，同时，允许利用金山词霸帮助阅读的时候，即时显示与即时发音；

B、利用孔兄的编码，将阅读中的生词逐个拾捡后，集中发往新建文档（这样做是能够在阅读时使用金山词霸即时显示与即时发音的功能）。再于新建文档中，一次性将生词转为词汇表。——这个方案同样适用于：下载的生词表中没有音标与释义，需要为这批生词标注音标与释义。

四、小弟羞于言说的问题。

使用了这许久老大与孔兄为小弟花费了极多心血的杰作，小弟至今仍然不晓得：

1、如何把孔兄的编码嵌入Normal.dot中使用？（阅读一般文章时，不打开孔兄的这个界面；需要阅读英语文章时，可以手工打开孔兄的这个界面，进行词汇表生成工作）

小弟尝试的方法是将孔兄的《前三步》打开，开启时选择“禁用宏”，转存为dot模板，再于“工具→模板和加载项→添加”里加载，可是无效。

如果直接复制代码到“Normal→模块→NewMacros”中，亦不能生效。

2、如何把老大的代码嵌入Normal.dot中使用？

小弟把老大的代码从“Projectd（生词列表）→Microsoft Word 对象→ThisDocument”原原本本粘贴到“Normal→模块→NewMacros”中后，时常会跳出一个消息框：“编译错误：发现二义性的名称：Document_open”，在与之同时出现的VBE界面中，指向了以下这个位置：

Private Sub Document_Open()
'指向Application对象
    Set wdApp = Word.Application
End Sub

往往点了消息框里的“确定”按钮一次后，还会马上再跳出一次这个消息框，甚至第三次出现这个消息框。

而后，无法运行Normal里的任何其他宏。一运行，都弹出这样的消息框：“由于宏安全设置，无法找到宏或宏被禁用”。

这是极低级的问题，奈何小弟就是弄不明白。在老大的《Word非常接触》里找不到，于论坛、Goole中无法使用合适的关键字搜索。悲哀之极！

特请二老揭示其中堂奥！小弟感激在心，一言难尽！

仍然是一大堆没头没脑的话，二老费力看了之后，又要大费心了！这样的大冷天，小弟做不了什么，为二老弄个小火炉来取暖吧！呵呵！谢谢二老！

[此贴子已经被作者于2006-12-12 23:25:19编辑过]

守柔

TO 雨兄：

关于屏幕取词，我所提供的代码中，没有要求必须禁用屏幕取词，您可以试一下。

关于二义性的名称，因为你的NORMAL.DOT的THISDOCUMENT中，包含了两个相同对象的相同事件过程，如Private Sub Document_Open()

你需要删除。

小弟把老大的代码从“Projectd（生词列表）→Microsoft Word 对象→ThisDocument”原原本本粘贴到“Normal→模块→NewMacros”中后，错误！，应该粘贴到Thisdocument代码窗口中，这是类模块的事件（DOCUMENT_open())。

注意，我的代码粘贴到Normal的Thisdocument中时，请在VBE中引用MSFORM。

第三个问题，我的右键菜单，是结合手动自定义与代码自定义的，因此，你会发现找不到宏或者宏禁用的提示，按照P149页自定义右键菜单并将宏指定到该右键中即可，注意，自定义的右键菜单名称为“To 生词表”，注意大小写。

雨雪霏霏

　　非常感谢老大的详细解析！
　　老大所言，将小弟困惑已久的问题一下解决了！真是字字皆中的！
　　1、关于屏幕取词。
　　小弟也曾尝试开启屏幕取词功能，只是中毒之后，电脑一直无法正常工作，因此，一开启屏幕取词功能之后，金山词霸界面就无法一闪即逝，而是一直停留在那儿。小弟便估想，这和老大以前的《自动加注音标》说明文字中的“并关闭屏幕取词功能”要一致，于是，小弟便关闭了屏幕取词功能了（老大这一次的代码中，也延用了《自动加注音标》的文字说明里）。
　　经老大提醒，小弟再反复重启电脑测试，确实，老大的《自动加注音标》和现在的代码，都可以在不关闭屏幕取词功能的情况下顺利运行（小弟目前测试的是金山词霸2006）。这可解决了小弟先前的苦恼了！感谢老大的说明！（提醒：《Word非常接触》光盘中，《自动加注音标》编码的文字说明里是否应该删去“并关闭屏幕取词功能”呢？请老大指点！）
　　2、关于二义性名称。
　　小弟把ThisDoceument里的其他宏编码删除之后，只剩下老大的代码，确实可以顺利运行老大的程序。
只是又有了新苦恼：无法使用ThisDoceument中以前的宏编码了——先前，孔兄帮小弟写了日记模板的程序，其中也有一部分是需要放在ThisDoceument下的。删去孔兄的代码，小弟便无法使用孔兄的心血结晶了。于孔兄的劳苦上，颇说不过去；而于小弟的实际需要上看，又确实难以割舍。
　　不知老大有没有办法做到使它们无法冲突？
　　另：延用了老大今天教的办法，如果在ThisDoceument中只保留孔兄《前三步》的宏，也是可以在全局模板中顺利运行孔兄的代码的。于是，这样一来，小弟目前的情形便是：二老的三个好代码，小弟只能选择保留一个在ThisDoceument中。小弟心痛！凭着对VBA的猜想，小弟以为，大概也只能是三选一了，而无法三选三！但还是求教一下二老，看看有无一线希望！感激不尽！
　　3、关于右键菜单。
　　感谢老大的说明，小弟已经顺利完成。《Word非常接触》中，老大与如意版主指点得非常明白！

　　现在，小弟对整个自动生词表的设想如下，只是不知老大的时间与精力允许否：
　　1、目前的结果是，词性与中文释义分成了两段。理想的效果是词性与中文释义合在一段，并且，词性与中文释义中间有一个半角空格隔开。
　　目前的结果是，如果某个单词在金山词霸中没有音标，老大的编程则把词性提取过来“当成”了音标，而在中文释义一列没有了词性。这造成了一些混乱。理想的效果是没有音标的，则音标单元格为空，仍然把词性与中文释义合在一起。
　　当然，这两个方面都可以最后由手工来操作完成，而且也不是太麻烦。请老大明示！
　　1、对于已经在一个新文档中，且每个单词为一行（或称为一段）的批量的生词，理想中，除了能够利用《自动加注音标》为它们标注音标之外，小弟也十分期待能够有一个新程序把它们一次性转成词汇表。
　　每一个小弟的“理想”，都要耗费老大巨量的精神气力！小弟至今未能给老大送去一点什么营养汤一类的，只有日复一日年复一年的向老大索取，没有任何东西回报，而老大毫不以为意，小弟只能默默记心上了！

　　To 孔兄：非常感谢孔兄的体贴！小弟现在已经可以顺利运行孔兄的代码了。只是面临着“三选一”的困局，小弟大概只能选择这样十分低效的做法了：需要三者中的一个代码的时候，就把其他的都删除了，换上这个代码。

　　再次感谢二老对小弟的倍加关爱！

　　最后特别感谢——有了老大与如意版主的《Word非常接触》，小弟像一只小鱼游入了大海，可以昼夜畅游了！（当然，现在还不敢往深里游，再过一段时间，一定好好请教老大、如意版主与孔兄！）

守柔

成品附件如下：

dVklByjR.rar (28.83 KB, 下载次数: 17031)

2006-12-14 06:57 上传

点击文件名下载附件

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2006-12-15 6:31:24
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0118^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Private WithEvents wdApp As Word.Application

Sub Example()
'本程序仅在金山词霸2003\2005上正确通过
'写在前面:您运行此程序前必须引用MSForms
'即VBE/工具/引用:Microsoft Forms 2.0 Object Library (C:\WINNT\system32\FM20.DLL)
'打开金山词霸
    Dim myRange As Range, myTable As Table, TF As Boolean
    Dim EngWord As String, myString() As String, myRow As Row
    Dim aString As String, bString As String, cString As String
    Dim KeyString As String
    If Tasks.Exists("金山词霸") = False Then
        MsgBox "您必须先运行金山词霸程序!!", vbCritical, "ExcelHome"
        Exit Sub   '如果未在任务栏中则关闭程序
    End If
    With Selection
        '如果不是光标状态则退出(非选定内容状态)
        If .Type <> wdSelectionIP Then Exit Sub
        EngWord = .Words(1)
        '如果光标后的单词不是英文单词则退出
        If Not EngWord Like "[A-z]*" Then Exit Sub
    End With

[此贴子已经被作者于2006-12-15 6:32:28编辑过]

守柔

    Application.ScreenUpdating = False    '关闭屏幕更新
    bString = GetPhonetic(EngWord)    '取得词霸中的内容
    myString = VBA.Split(bString, vbCrLf)    '返回一个数组
    aString = myString(1)    '取得数组中的第二个值,也就是音标
    cString = myString(0)    '单词本身(也许是相近的单词)
    '    Debug.Print aString
    '判断该单词有无音标
    If VBA.InStr(aString, "[") = 0 Then aString = ""
    bString = VBA.Replace(bString, cString & vbCrLf, "")
    bString = VBA.Replace(bString, aString & vbCrLf, "")
    bString = VBA.Replace(bString, vbCrLf, " ")    '将词性与中文释义中间的段落标记改为空格
    '    MsgBox bString
    '    MsgBox aString
    KeyString = "----------我的生词表----------"
    With ActiveDocument
        Set myRange = .Content
        With myRange.Find
            .ClearFormatting
            .Text = KeyString & "^p"
            TF = .Execute
        End With
        If TF = True Then
            myRange.SetRange myRange.Start, .Content.End - 1
            Set myTable = myRange.Tables(1)
        Else
            .Content.InsertAfter Chr(13) & KeyString & Chr(13)
            Set myRange = .Range(.Content.End - 1, .Content.End - 1)
            Set myTable = .Tables.Add(Range:=myRange, numrows:=2, numcolumns:=4)
            With myTable
                .Style = "网格型"
                .Cell(1, 1).Range.Text = "序"
                .Cell(1, 2).Range.Text = "生词"
                .Cell(1, 3).Range.Text = "音标"
                .Cell(1, 4).Range.Text = "释义"
                .Columns(1).PreferredWidthType = wdPreferredWidthPercent

守柔

                .Columns(1).PreferredWidth = 10
                .Columns(2).PreferredWidthType = wdPreferredWidthPercent
                .Columns(2).PreferredWidth = 20
                .Columns(3).PreferredWidthType = wdPreferredWidthPercent
                .Columns(3).PreferredWidth = 20
                .Columns(4).PreferredWidthType = wdPreferredWidthPercent
                .Columns(4).PreferredWidth = 50
            End With
        End If
        With myTable
            Set myRow = .Rows.Last
            Set myRow = .Rows.Add(myRow)
            With myRow
                .Range.Font.Name = "Tahoma"
                Set myRange = .Cells(1).Range
                With myRange
                    .SetRange .Start, .Start
                    .Fields.Add Range:=myRange, Type:=wdFieldEmpty, Text:="SEQ  生词\* ARABIC", preserveformatting:=False
                End With
                .Cells(2).Range.Text = EngWord
                Set myRange = .Cells(3).Range
                With myRange
                    If VBA.LCase(cString) <> VBA.LCase(Trim(EngWord)) Then

守柔

                        bString = "没找到!": aString = "没找到!"
                        .Text = aString
                    Else
                        If aString = "" Then
                        Else
                            .Text = aString
                            .SetRange .Start + 1, .End - 3
                            .Font.Name = "Kingsoft Phonetic Plain"
                        End If
                    End If
                End With
                .Cells(4).Range.Text = bString
            End With
            .Range.Fields.Update
        End With
    End With
    Application.ScreenUpdating = True
End Sub
'----------------------
Function GetPhonetic(EwTxt As String) As String
    Dim MyData As DataObject
    On Error Resume Next
    Tasks("金山词霸").WindowState = wdWindowStateNormal    '正常窗口
    Set MyData = New DataObject    '引用DataObject
    Tasks("金山词霸").Activate    '激活金山词霸应用程序
    SendKeys EwTxt, True    '发送单词
    SendKeys "{TAB 2}", True    '移动二次TAB
    SendKeys "^c", True    '复制
    MyData.GetFromClipboard    '从剪贴板复制数据到 DataObject
    GetPhonetic = MyData.GetText(1)    '获得无格式文本
    MyData.Clear    '清空剪贴板
    AppActivate "Microsoft Word"     '激活WORD文档
End Function
'----------------------

守柔

Private Sub Document_Open()
'指向Application对象
    Set wdApp = Word.Application
    '如果这个地方你需要执行该事件下的其它过程,或将代码粘贴于此处,或者使用CALL *过程名的方式进行
    '如
    'Call KonggsSub
End Sub
'----------------------

Private Sub wdApp_WindowBeforeRightClick(ByVal Sel As Selection, Cancel As Boolean)
'修改右键菜单
    If Sel.Type = wdSelectionIP Then
        If VBA.InStr(Word.CommandBars("Text").Controls(1).Caption, "To") Then
            Word.CustomizationContext = ActiveDocument
            If Sel.Words(1) Like "[A-z]*" Then
                Word.CommandBars("Text").Controls(1).Caption = Sel.Words(1) & " To 生词表"
                Word.CommandBars("Text").Controls(1).Visible = True
            Else
                Word.CommandBars("Text").Controls(1).Visible = False
            End If
        End If
    End If
End Sub
'----------------------

守柔

Sub GetParsPhonetic()
'为文档中段落的每个单词(一个段落一个单词)列表\加注音标和释义
    Dim myPars As String, myArray() As String, aArray As Variant
    Dim myRange As Range, myTable As Table, myString() As String, myRow As Row
    Dim aString As String, bString As String, cString As String
    On Error Resume Next
    Application.ScreenUpdating = False
    With ActiveDocument
        myPars = .Content
        .Content.Delete
        Set myRange = .Range(0, 0)
        Set myTable = .Tables.Add(Range:=myRange, numrows:=2, numcolumns:=4)
        With myTable
            .Style = "网格型"
            .Cell(1, 1).Range.Text = "序"
            .Cell(1, 2).Range.Text = "生词"
            .Cell(1, 3).Range.Text = "音标"
            .Cell(1, 4).Range.Text = "释义"
            .Columns(1).PreferredWidthType = wdPreferredWidthPercent
            .Columns(1).PreferredWidth = 10
            .Columns(2).PreferredWidthType = wdPreferredWidthPercent
            .Columns(2).PreferredWidth = 20
            .Columns(3).PreferredWidthType = wdPreferredWidthPercent
            .Columns(3).PreferredWidth = 20
            .Columns(4).PreferredWidthType = wdPreferredWidthPercent
            .Columns(4).PreferredWidth = 50
        End With
        myArray = VBA.Split(myPars, Chr(13))
        For Each aArray In myArray
            aArray = VBA.Replace(aArray, " ", "")
            If aArray = "" Then
            Else
                bString = GetPhonetic(CStr(aArray))    '取得词霸中的内容
                myString = VBA.Split(bString, vbCrLf)    '返回一个数组
                aString = myString(1)    '取得数组中的第二个值,也就是音标
                cString = myString(0)    '单词本身(也许是相近的单词)
                '    Debug.Print aString
                '判断该单词有无音标

守柔

                If VBA.InStr(aString, "[") = 0 Then aString = ""
                bString = VBA.Replace(bString, cString & vbCrLf, "")
                bString = VBA.Replace(bString, aString & vbCrLf, "")
                bString = VBA.Replace(bString, vbCrLf, " ")    '将词性与中文释义中间的段落标记改为空格
                With myTable
                    Set myRow = .Rows.Last
                    Set myRow = .Rows.Add(myRow)
                    With myRow
                        .Range.Font.Name = "Tahoma"
                        Set myRange = .Cells(1).Range
                        With myRange
                            .SetRange .Start, .Start
                            .Fields.Add Range:=myRange, Type:=wdFieldEmpty, Text:="SEQ  生词\* ARABIC", preserveformatting:=False
                        End With
                        .Cells(2).Range.Text = aArray
                        Set myRange = .Cells(3).Range
                        With myRange
                            If VBA.LCase(cString) <> VBA.LCase(Trim(aArray)) Then
                                bString = "没找到!": aString = "没找到!"
                                .Text = aString
                            Else
                                If aString = "" Then
                                Else
                                    .Text = aString
                                    .SetRange .Start + 1, .End - 3
                                    .Font.Name = "Kingsoft Phonetic Plain"
                                End If
                            End If
                        End With
                        .Cells(4).Range.Text = bString
                    End With
                    .Range.Fields.Update
                End With
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub
'----------------------