|
|
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
Next
Application.ScreenUpdating = True '恢复屏幕更新工作
Tasks(VBA.Replace(.Name, ".doc", "")).Activate '激活WORD文档
'提示
MsgBox "自动音标标注工作已经结束!", vbInformation + vbOKOnly, "Microsoft Word"
End With
End Sub
'----------------------
单词风暴也可以的，你可以百度搜单词风暴官网下载，你输入单词，词组，句子，它自动匹配音标的
可以参考这个，百度搜下就行了《万能词库制作——最好的背单词软件“单词风暴”领先于同类产品的必杀技 》
2、分享 作者：风凌 E - mail:hchaoming@163.com
用金山词霸自动给单词添加音标和解析
━━━━━━━━━━━━━━━━━━━━━━━━━
利用ActiveX引用金山词霸自动给英文word文档里光标处（或选择）的英文单词添加音标和解析的VBA代码
这是一个利用ActiveX引用金山词霸自动给英文word文档里光标处（或选择）的英文单词添加音标和解析的VBA代码。
作者：风凌 E - mail:hchaoming@163.com
注意事项
1.使用时请确保安装有PowerWord2006，添加引用“KSEngine1.0TypeLibrary”
2.如果安装了其他版本的金山词霸，可以自行调试，
3.程序里添加词库的命令视具体的安装路径和词库位置而定。
4.如果没有也不想安装金山词霸的运用程序，可以直接“引用”附件里的KSEngine.dll，词库也可直接使用附件中提供的PWQEC.DIC词库，注意KSEngine.dll保存在本地磁盘不能使用中文路径，否则创建对象时出错。
5.另外，为方便使用，1).可将本程序写在normal工程中，将对其他word文档也可见； 2).可将本宏命令添加到word得自定义工具栏中。
6.欢迎大家改进，帮助完善 * ^^ * 请E - mail我。2009.05.30
━━━━━━━━━━━━━━━━━━━━━━━━━
Option Explicit
Sub Qklookup()
Dim boolSelMode As Boolean
Dim strMyWord As String
Dim Myrange As Range, Mystart As Long
Dim Dic As KSENGINELib.Dictionary
Dim i As Integer
Application.ScreenUpdating = False '关闭屏幕更新
boolSelMode = True ' 取词方式 设定标志True为光标取词，false为选中取词
If boolSelMode Then
With Selection.Words(1)
strMyWord = RTrim(.Text)
For i = 1 To .Characters.Count - 1
.Characters(i).Font.Bold = True
.Characters(i).Font.Shadow = True
.Characters(i).Font.Shading.Texture = wdTexture20Percent
Next
Mystart = .End
End With
Else
With Selection
strMyWord = .Text
.Font.Bold = True
.Font.Shadow = True
.Font.Shading.Texture = wdTexture20Percent
Mystart = .Range.End + 1
End With
End If
on Error Resume Next
Set Dic = New KSENGINELib.Dictionary
Dic.Open "C:\Program Files\Kingsoft\PowerWord 2006\DICTS\PWQEC.DIC"
If Err Then
MsgBox "无法打开字典词库"
Err.Clear
Exit Sub
End If
Dic.Lookup strMyWord, 3
If Err Then
MsgBox "找不到该单词，请修改单词 或 更新词库"
Err.Clear
Exit Sub
End If
Set Myrange = ActiveDocument.Range(Mystart, Mystart)
Myrange.InsertAfter "(["
Mystart = Myrange.End
Set Myrange = ActiveDocument.Range(Mystart, Mystart)
Myrange.InsertAfter Dic.GetPhonetic
Myrange.Font.Name = "Kingsoft Phonetic Plain"
Mystart = Myrange.End
Set Myrange = ActiveDocument.Range(Mystart, Mystart)
Myrange.InsertAfter "]" & Dic.GetExplain & ") "
Myrange.Font.Name = "Times New Roman"
End Sub
3、VBA 有道单词本源码
' 1.将以下程式码复制到Excel VBA 模组(Module)中
'
' 2.在Excel工作表中A Column输入要批量翻译的生词列表
'
' 3.若要转出有道xml格式单词库文件，请执行xmlVocabulary，汇出的档案位置为Excel活页簿位置，档案名称为 "工作表名称.xml "
'
' 4.若要批量翻译直接写入Excel档，请执行xlsmVocabulary
'
' 5.先以少量生词列表测试翻译速度，我自己1000个字大概花7~8分钟翻译
'
' 6.若要现成的Excel档，请网搜 "有道单词本.xlsm "
Private Type Character
word As String
trans As String
phonetic As String
tags As String
'progress As Integer
End Type
'汇出有道xml格式单词库文件
Sub xmlVocabulary()
Dim newChar As Character
Dim R As Range
Dim Row As Range
Dim strOutput As String
Dim arrBytes() As Byte
newChar.tags = ActiveSheet.name
ActiveSheet.Names.Add name: = "NewWord", RefersTo: = "=OFFSET($A$1,0,0,COUNTA($A:$A))"
Set R = ActiveSheet.Names("NewWord").RefersToRange
strOutput = ""
For Each Row In R.Rows
newChar.word = Trim(Row(1))
Call searchWord(newChar.word, newChar.trans, newChar.phonetic)
strOutput = strOutput & vbCrLf & ""
strOutput = strOutput & vbCrLf & "" & newChar.word & ""
strOutput = strOutput & vbCrLf & "" & newChar.trans & ""
strOutput = strOutput & vbCrLf & "" & newChar.phonetic & ""
strOutput = strOutput & vbCrLf & "" & newChar.tags & ""
strOutput = strOutput & vbCrLf & "1"
strOutput = strOutput & vbCrLf & ""
Next Row
strOutput = strOutput & vbCrLf & ""
arrBytes = ChrW( &HFEFF) & strOutput '写入unicode文字码
Open Application.ActiveWorkbook.Path & "\" & newChar.tags & ".xml" For Binary As #1 '建立xml格式档案
Put #1, , arrBytes
Close #1
End Sub
'单词音译写入Excel档
Sub xlsmVocabulary()
Dim newChar As Character
Dim R As Range
Dim Row As Range
Dim rr As Integer
strTags = ActiveSheet.name
ActiveSheet.Names.Add name: = "NewWord", RefersTo: = "=OFFSET($A$1,0,0,COUNTA($A:$A))"
Set R = ActiveSheet.Names("NewWord").RefersToRange
rr = 0
For Each Row In R.Rows
rr = rr + 1
newChar.word = Trim(Row(1))
Call searchWord(newChar.word, newChar.trans, newChar.phonetic)
Worksheets(strTags).Cells(rr, 2).Value = newChar.phonetic '撷取音标
Worksheets(strTags).Cells(rr, 3).Value = newChar.trans '撷取翻译
Next Row
End Sub
Sub searchWord(tmpWord As String, tmpTrans As String, tmpPhonetic As String)
'http://dict.youdao.com/search?q=单词&keyfrom=dict.index
Dim XH As Object
Dim s() As String
Dim str_tmp As String
Dim str_base As String
tmpTrans = ""
tmpPhonetic = ""
'开启网页
Set XH = CreateObject("Microsoft.XMLHTTP")
on Error Resume Next
XH.Open "get", "http://dict.youdao.com/search?q=" & tmpWord & "&keyfrom=dict.index", False
XH.send
on Error Resume Next
str_base = XH.responseText
XH.Close
Set XH = Nothing
str_base = Split(Split(XH.responseText, "")(0), "")(1)
'撷取音标
If UBound(Split(str_base, "美")) = 1 Then
'美式音标
tmpPhonetic = Split((Split(Split(str_base, "美")(1), "")(1)), "")(0)
on Error Resume Next
Else
tmpPhonetic = Split((Split(str_base, "")(1)), "")(0)
on Error Resume Next
End If
'撷取中文翻译
str_tmp = Split((Split(str_base, "")(1)), "")(0)
str_tmp = Split((Split(str_tmp, "
")(1)), "
")(0)
s = Split(str_tmp, "
")
tmpTrans = Split(s(LBound(s) + 1), "
")(0)
For i = LBound(s) + 2 To UBound(s)
tmpTrans = tmpTrans & Chr(10) & Split(s(i), "
")(0)
Next
End Sub
|
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2019-10-7 18:07
楼主
