请问 有没有软件可以实现自动标注英文音标的功能？

Question

比如中英互译那样的软件，给一段中文，软件就可以翻译英文；
想找一个软件，给一段英文，软件就可以加注英文音标。
谢谢

Answer 1

分享]WORD与金山词霸-自动标注音标的小程序
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* 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