'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ExcelHome 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