[分享]WORD中的拼音加注程序

守柔

引子：WORD中加注拼音，是用格式/中文版式/拼音指南完成，其中一次标注数量有限，更主要的是它不支持VBA的开发（拼音源至微软拼音2.0或以上版本).

在WORD中使用拼音的程序,较EXCEL要复杂,要慢得多,这个程序中,受拼音库数量影响,部分文字可能不会加注拼音,对多音字也无法识别,请各位在运行中多提意见,以便修改.

使用方法:

打开本程序(文档),打开需要注拼音的文档(已有文件名),再运行本程序中的"RUN"命令,将会在新文档中注音.

本程序所使用的简体拼音库摘在"jack.zhou" 的贴子中.

frczvmJ1.zip (310.79 KB, 下载次数: 504)

2004-7-14 15:28 上传

点击文件名下载附件
[分享]WORD中的拼音加注程序

守柔

音调标志受数据（拼音）库制约，暂时未找到更好的。

WORD中的主要功能是进行文字处理，而我们的汉字是主要对象，进行汉字的注音功能，也是一个用途。

今天，终于完成一个较为满意的注音程序，它通过调用EXCEL程序（这样检查较WORD中快，也更方便），此程序较之一楼的速度要快。请各位进行测试。（请将代码部分粘贴于全局模板中（NORMAL.DOT THISDOCUMENT中)

'请将此代码粘贴于全局模板中. Sub GetPinYin() Dim xlObj As Excel.Application, xlWb As Excel.Workbook, Hz As Range, HzRange As Excel.Range, c As Excel.Range, PY As String Dim WordDoc As Document, Range1 As Range, AtdName As String, DefPath As String On Error GoTo ErrHandle Application.ScreenUpdating = False AtdName = ActiveDocument.Name '取得活动本档名 DefPath = Options.DefaultFilePath(wdDocumentsPath) '取得默认WORD文件夹位置 Set WordDoc = Documents.Add '设置新文档 Documents(AtdName).Activate '返回活动文档 If Tasks.Exists("Microsoft Excel") = True Then '检查并建立EXCEL程序 Set xlObj = GetObject(, "Excel.Application") Else Set xlObj = CreateObject("Excel.Application") End If Set xlWb = xlObj.Workbooks.Open(DefPath & "\ExPinYin.xls") '打开该简体拼音工作薄 Set Myrange = xlWb.Sheets(1).Range("a1:a6763") '设置区域 For Each Hz In ActiveDocument.Characters '在活动文档中遍历每个字 With Myrange Set c = Myrange.Find(Hz, LookIn:=xlValues) If Not c Is Nothing Then PY = c.Offset(, 1) '取得工作薄中的拼音 Hz.PhoneticGuide Text:=PY, FontSize:=10 '加注拼音指南,注意此时已变成域 ActiveDocument.Fields(1).Cut '剪切域 Else Hz.Cut '剪切没有找到的文字 End If End With With WordDoc Set Range1 = .Content '在新文档的最后粘贴剪贴板上的内容 Range1.Collapse Direction:=wdCollapseEnd Range1.Paste End With Next xlObj.Quit '关闭EXCEL程序 WordDoc.Activate WordDoc.SaveAs FileName:="PinYin" & AtdName '保存新文档 MsgBox "自动拼音加注已完成!" Application.ScreenUpdating = True Exit Sub ErrHandle: MsgBox "请检查各文件位置或者活动文档的文本内容是否超过了32000个汉字" End Sub 附件见楼下,请注意将EXCEL工作薄ExPinYin.XLS 保存于WORD文件的默认文件夹中!

守柔

了了一个小心愿.

Zx0BaJ8N.zip (113.03 KB, 下载次数: 180)

2004-7-16 14:43 上传

点击文件名下载附件
[分享]WORD中的拼音加注程序

这是原来(一楼)的代码,一楼的文件要较三楼大得多!

Sub PinYin() Dim WordDoc As Document, i As Range, PY As String, Range1 As Range, Ipd As String, Jc As Document 3: Application.ScreenUpdating = False MsgBox "请确认已打开要加注拼音的文件" Ipd = InputBox("请输入需要加注拼音的文件名,无需后缀!") If Ipd = "" Then Exit Sub Err.Number = 0 On Error Resume Next Documents(Ipd & ".doc").Activate If Err.Number <> 0 Then Err.Clear MsgBox "请检查文件名的正确性!" GoTo 3 End If Set WordDoc = Documents.Add Documents("汉字拼音字库.doc").Activate For Each i In Documents(Ipd & ".doc").Content.Characters If i Like Chr(13) = True Or i Like "[A-Z]*" = True Or i Like "#" = True Or i Like "[a-z]" = True Then i.Copy i.Delete Else With ActiveDocument.Content Range(0, 0).Select .Find.Execute Findtext:=i, Forward:=True If .Find.Found = True Then .Find.Parent.Select Selection.MoveRight Unit:=wdCell PY = Selection i.PhoneticGuide Text:=PY, FontSize:=10 Documents(Ipd & ".doc").Fields(1).Cut Else i.Cut End If End With End If With WordDoc Set Range1 = .Content Range1.Collapse Direction:=wdCollapseEnd Range1.Paste End With Next WordDoc.Activate WordDoc.SaveAs Ipd & "PinYin.doc" Application.ScreenUpdating = True End Sub

Private Sub commandbutton1_Click() Call PinYin End Sub

守柔

忘了说了：

请在VB编辑器的工具菜单/ 引用中勾选：Microsoft Excel 10.0 object library.

如图:

[此贴子已经被作者于2004-7-16 18:22:49编辑过]

wenz

谁是语文老师,还不献花.

守柔

[em17]！

试了一下感觉很好！

有几个问题：

SendKeys "{enter}{enter}", False？这句话为什么感觉这句话是关键。

另外对于标点等不能跃过(这倒不难办）

通过HZ的FOR EACH循环受已添加域的影响，RANGE对象发生了变化最后将多出部分RANGE，所以可能将出现多处“SendKeys "{enter}{enter}", False”

微软这鬼东西真是绝，明明dialogs(986),就是拼音指南的对话框就是不让预置属性，以下代码是错误的：

Set MyDialog = Dialogs(986) With MyDialog .FontSize = 10 .Execute End With 更可气是在帮助中找不到该对话框的常用属性设置，连wddialogFormatPhoneticGuide都没有但是如果将fieldsun 兄的一句application.run macroname:="FormatPhoneticGuide"去掉，用

Set MyDialog = Dialogs(986) With MyDialog .FontSize = 10 .Execute End With

也行得通（on error resume next(fontsize处出错））。

还有问题呢，看看转成的域，{EQ \* jc2 \* "Font:宋体" \* hps20 \o\ad(\s\up 9(nà),那}

jc2是什么东东？

我晕！

哎，学然后知不足也！（先说这么多）

守柔

以下是引用fieldsun在2004-7-17 12:40:00的发言：

我一直有个心愿,是直接调用微软拼音给WORD文档加拼音,用以下代码直接调用格式中拼音指南,仍不如意,拼音的对齐,字体\字号等不知道如何加,执行中也有问题,请守柔版主看看如何改进(OFFICE2000以上+微软拼音3.0)

在fieldsun版主的帮助下，总算可以再次杀青了，请大伙儿在测试测试，以便我及时改正：

Sub GetPYin() Dim i As Range, FieldCount1 As Integer, FieldCount2 As Integer, ConEnd As Long, IpNumber As String Dim StartRange As Long On Error Resume Next Application.ScreenUpdating = False Selection.WholeStory IpNumber = InputBox("您必须为拼音指定统一字号，请在此输入（5~20）", "汉字自动加注拼音") If IpNumber = "" Then Exit Sub Else Selection.Font.Size = CByte(IpNumber) * 2 End If For Each i In ActiveDocument.Characters If ActiveDocument.Fields.Count = 0 Then StartRange = 0 Else FieldCount1 = ActiveDocument.Fields.Count ActiveDocument.Fields(FieldCount1).Select Selection.Move StartRange = Selection.Start End If ConEnd = StartRange + 30 If ConEnd > ActiveDocument.Content.End Then ConEnd = ActiveDocument.Content.End Range(StartRange, ConEnd).Select SendKeys "{enter}", False Application.Run "FormatPhoneticGuide" FieldCount2 = ActiveDocument.Fields.Count If FieldCount1 = FieldCount2 Then Exit For Next Selection.WholeStory Selection.Font.Size = CByte(IpNumber) * 1.5 ActiveDocument.Range(0, 0).Select Application.ScreenUpdating = True End Sub

守柔

超酷，特爽！

试运行为近4800（含少量标点）的文字，加拼音，才一分钟多一点!(P4+2.4G)

守柔

TO FIELDSUN兄：

我测试时该代码正常，未发生错误情况，只是对于引用，应该无关吧（我未引用该MS EXCEL 9.0 OBJECT LIBRARY）；

另外，该代码运行时由于从后到前，因此i=charcount to 0 step -1时，最后一个字才能被注音。

只是由于一个一个注，加之又要进行判断，故相对运行速度要慢些。

而9楼的代码中，从前向后，每三十个字符一次性加注拼音，故而速度相对要快些，并且巧妙地应用WORD自带的多字节注音中的错误回避功能，不需判断是否为非汉字文字。

总体上说，很是不错的。但是否可以考虑以下几个问题：

拼音的大小问题及多字节加音呢？

守柔

OitkKmn0.zip (13.52 KB, 下载次数: 68)

2004-7-21 12:39 上传

点击文件名下载附件
[分享]WORD中的拼音加注程序

这是我运行9楼代码的结果.(可能是版本问题占大面)