|
以下是引用小辨子在2004-9-4 17:09:00的发言：
Ga8MakY5.rar
(122.58 KB, 下载次数: 30)
请注意你注意将两个文件解压于同一文件夹中。
以下为代码：供参考（部分汉字注释在粘贴过程中变形请在附件中打开）
Sub GetPinYin1()
Dim xlObj As Excel.Application, xlWb As Excel.Workbook, Hz As Cell, HzRange As Excel.Range
Dim MyTable As Table, H As Range, C As Excel.Range
Application.ScreenUpdating = False
Set MyTable = ActiveDocument.Tables(1)
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(ActiveDocument.Path & "\ExPinYin.xls") '´ò¿ª¸Ã¼òÌåÆ´Òô¹¤×÷±¡
Set Myrange = xlWb.Sheets(1).Range("a1:a6763") 'ÉèÖÃÇøÓò
For Each Hz In MyTable.Columns(2).Cells
If Hz.RowIndex > 1 Then
For Each H In Hz.Range.Characters
If H Like Chr(13) = True Then Exit For
With Myrange
Set C = Myrange.Find(H, LookIn:=xlValues)
If Not C Is Nothing Then
MyTable.Cell(Hz.RowIndex, 3).Range.InsertAfter C.Offset(, 3)
End If
End With
Next
End If
Next
xlObj.Quit '¹Ø±ÕEXCEL³ÌÐò
Set xlObj = Nothing
Application.ScreenUpdating = True
Exit Sub
End Sub
Private Sub Document_Open()
On Error Resume Next
'µ÷ÓÃEXCEL.Ï൱ÓÚVB±à¼Æ÷ÖеŤ¾ßÒýÓÃ,ÔÚMicrosoft EXCEL 10.0 ¡¡Ç°´ò¹´
ActiveDocument.VBProject.References.AddFromFile "C:\Program Files\Microsoft Office\Office" & Mid(Application.Version, 1, 2) & "\Excel.exe"
End Sub
| 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2004-9-4 11:49
楼主