有道单词本

' 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 =

s.Add name:="NewWord", RefersTo:="=OFFSET($A$1,0,0,COUNTA($A:$A))"

Set R = s("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 & ""

strOutput = strOutput & vbCrLf & "" 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 =

s.Add name:="NewWord", RefersTo:="=OFFSET($A$1,0,0,COUNTA($A:$A))"

Set R = s("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)

'/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", "/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