英语学习小工具-取音释义 V1.3
本帖最后由 addision 于 2018-10-13 09:18 编辑原贴由于时间久远，不能再编辑，按吾友需求更新了一下内容，发新贴@infox
原贴地址
https://www.52pojie.cn/thread-799354-1-1.html
-------------------------------------------更新内容---------------------------------------------------------
1.新增必应借口
2.取音释义的数据存到Record表格
3.增加单个查询和批量查询
-单个查询使用方法，复制需查询的单词，然后点击单个查询按钮，自动会查询，然后粘贴到最后一行
测试环境：Office2010 x32 Office2016 x32Office365无问题
低版本的朋友，建议升级
-------------------------------------------动图说明--------------------------------------------------------
给个热心评分啊 各位兄弟
-------------------------------------------源码分享---------------------------------------------------------
希望有兴趣的朋友 可以增加新内容后分享大家使用
Private Type Character
word As String
trans As String
phonetic As String
End Type
Public iZidian As Integer
Sub Bing()
Range("D1").ClearContents
iZidian = 1
WriteVocabulary
Range("D1") = "Done"
Call CPa
End Sub
Sub Bing2()
Sheet1.Select
Range("A2").Select
ActiveSheet.Paste
Range("D1").ClearContents
iZidian = 1
WriteVocabulary
Range("D1") = "Done"
Call CPa
End Sub
Sub WriteVocabulary()
Dim newChar As Character
Dim R As Range
Dim rr, dd As Integer
Sheet1.Activate
ActiveSheet.Names.Add Name:="NewWord", RefersTo:="=OFFSET($A$1,0,0,COUNTA($A:$A))"
Set R = ActiveSheet.Names("NewWord").RefersToRange
Sheet1.Cells(1, 6).Value = ""
dd = R.Count - 1
For rr = 2 To dd + 1
newChar.word = R(rr)
Select Case iZidian
Case 1
Call searchWordFromBing(newChar.word, newChar.trans, newChar.phonetic)
Case Else
Call searchWordFromBing(newChar.word, newChar.trans, newChar.phonetic)
End Select
On Error Resume Next
Sheet1.Cells(rr, 2).Value = newChar.phonetic
Sheet1.Cells(rr, 3).Value = newChar.trans
Sheet1.Cells(1, 6).Value = rr - 1 & "/" & dd
Next rr
End Sub
Sub searchWordFromBing(tmpWord As String, tmpTrans As String, tmpPhonetic As String)
Dim XH As Object
Dim s() As String
Dim str_tmp As String
Dim str_base As String
tmpTrans = ""
tmpPhonetic = ""
Dim url As String
tmpWord = Replace(tmpWord, " ", "+")
url = "http://cn.bing.com/dict/search?q=" & tmpWord & "&go=%E6%8F%90%E4%BA%A4&qs=bs&form=CM"
Set XH = CreateObject("Microsoft.XMLHTTP")
On Error Resume Next
XH.Open "get", url, True
XH.send (Null)
On Error Resume Next
While XH.readyState <> 4
DoEvents
Wend
str_base = XH.responseText
XH.Close
Set XH = Nothing
yb = Split(Split(str_base, "<div class=""hd_prUS"">")(1), "<span class=""pos"">")(0)
hy = Split(str_base, "<div class=""hd_div1"">")(0)
hy = Split(hy, "<span class=""pos"">")
yb = Split(yb, "<div class=""hd_pr"">")
ybEN = DelHtml(Split(yb(0), "</div>")(0))
ybUS = DelHtml(Split(yb(1), "</div>")(0))
tmpPhonetic = ybEN & ybUS
hytmp = ""
For i = LBound(hy) + 1 To UBound(hy)
hytmp = hytmp & DelHtml(Split(hy(i), "</span></span>")(0)) & vbCrLf
Next i
If UBound(hy) = 0 Then hytmp = ""
tmpTrans = hytmp
End Sub
Function DelHtml(strh)
Dim A As String
Dim RegEx As Object
A = strh
A = Replace(A, Chr(13) & Chr(10), "")
A = Replace(A, Chr(9), "")
A = Replace(A, "</p>", vbCrLf)
Set RegEx = CreateObject("vbscript.regexp")
With RegEx
.Global = True
.Pattern = "\<[^<>]*?\>"
.MultiLine = True
.ignorecase = True
A = .Replace(A, "")
End With
A = Trim(A)
A = Replace(A, "<", "<")
A = Replace(A, ">", ">")
A = Replace(A, "&", "&")
A = Replace(A, """, "\")
A = Replace(A, "&-->", vbCrLf)
A = Replace(A, "æ", ChrW(230))
A = Replace(A, " ", ChrW(160))
A = Replace(A, " ", " ")
DelHtml = A
End Function
Sub Down(p As Integer)
On Error Resume Next
Dim html As New HTMLDocument, i, url, w
With CreateObject("Microsoft.XMLHTTP")
For i = 2 To Sheet1.Range("A1").CurrentRegion.Rows.Count
w = Sheet1.Cells(i, 1).Value
url = IIf(p = 1, "http://dict.youdao.com/search?q=" & w & "&keyfrom=dict.index", IIf(p = 2, "http://dict.youdao.com/search?q=" & w & "&keyfrom=dict.index", IIf(p = 3, "http://dict.youdao.com/search?q=" & w & "&keyfrom=dict.index", "http://dict.youdao.com/search?q=" & w & "&keyfrom=dict.index")))
Debug.Print url
.Open "get", url, True
.send
While .readyState <> 4
DoEvents
Wend
html.body.innerHTML = .responseText
Select Case p
Case 1
Sheet1.Cells(i, 2) = html.getElementsByClassName("baav")(0).innerText
Sheet1.Cells(i, 3) = html.getElementsByClassName("trans-container")(0).innerText
Case Else
Sheet1.Cells(i, 2) = html.getElementsByClassName("prons")(0).innerText
Sheet1.Cells(i, 3) = html.getElementsByClassName("group_pos")(0).innerText
End Select
Sheet1.Cells(1, 6).Value = i - 1 & "/" & Sheet1.Range("A1").CurrentRegion.Rows.Count - 1
Next
End With
End Sub
Sub Youdao()
Range("D1").ClearContents
Application.Goto Sheet1.Range("A1")
Down 1
Range("D1") = "Done"
Call CPa
End Sub
Sub Youdao2()
Sheet1.Select
Range("A2").Select
ActiveSheet.Paste
Range("D1").ClearContents
Application.Goto Sheet1.Range("A1")
Down 1
Range("D1") = "Done"
Call CPa
End Sub
Sub CPa()
Dim aa%
aa = Sheet1..End(xlUp).Row
Range("A2:C" & aa).Copy
Dim i&
i& = Sheet2.Range("A1048576").End(xlUp).Row
i& = i& + 1
Sheet2.Select
Cells(i&, 1).Select
ActiveCell.FormulaR1C1 = i&
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheet1.Range("A2:C" & aa).ClearContents
End Sub
addision 发表于 2018-10-16 22:04
不好意思，最近比较忙，刚看了你的动图
你点击单个查询的时候，你要先复制一个单词，然后再点击按钮查 ...
刚试了下，确实如此。
Check表格 不输入单词按批量查询 有道不出错，必应会弹窗报错。建议把报错改成提示比较好。 本帖最后由 infox 于 2018-10-13 14:33 编辑
addision 发表于 2018-10-13 09:19
请查看动图，4个按钮在2016下测试没问题
详细请参考
链接: https://pan.baidu.com/s/1c0bkp9EcSCmDyNKSGg7hmA 提取码: 1111
感觉手上的表格和你的不太一样，必应好像没有道好用。 楼主，这个怎么使用呢 諦覠 发表于 2018-10-11 09:42
楼主，这个怎么使用呢
放上你需要查询的音标到A列，然后点击有道接口或者 必应 接口 即可，可以查看原贴 好牛的样子~！！~~！· 感谢大佬无私奉献收藏了 感谢分享！！！ 好像很厉害的样子，谢谢楼主分享 真的是个有心人！！！ 谢谢@Thanks！ 下载试试看！