英语学习小工具-取音释义 V1.3

文西思密达

原贴由于时间久远，不能再编辑，按吾友需求更新了一下内容，发新贴@infox


原贴地址
https://www.52pojie.cn/thread-799354-1-1.html


-------------------------------------------更新内容---------------------------------------------------------
1.新增必应借口
2.取音释义的数据存到Record表格
3.增加单个查询和批量查询
  -单个查询使用方法，复制需查询的单词，然后点击单个查询按钮，自动会查询，然后粘贴到最后一行

测试环境：Office2010 x32   Office2016 x32  Office365无问题
低版本的朋友，建议升级

-------------------------------------------动图说明--------------------------------------------------------



Study English Tool 1.3.rar (35.92 KB, 下载次数: 105)

2018-10-11 11:48 上传

点击文件名下载附件

给个热心评分啊 各位兄弟
-------------------------------------------源码分享---------------------------------------------------------
希望有兴趣的朋友 可以增加新内容后分享大家使用

[Visual Basic] 纯文本查看 复制代码

?

001 002 003 004 005 006 007 008 009 010 011 012 013 014 015 016 017 018 019 020 021 022 023 024 025 026 027 028 029 030 031 032 033 034 035 036 037 038 039 040 041 042 043 044 045 046 047 048 049 050 051 052 053 054 055 056 057 058 059 060 061 062 063 064 065 066 067 068 069 070 071 072 073 074 075 076 077 078 079 080 081 082 083 084 085 086 087 088 089 090 091 092 093 094 095 096 097 098 099 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174

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, "&#230;", 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.[a1048576].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

infox

addision 发表于 2018-10-16 22:04
不好意思，最近比较忙，刚看了你的动图

你点击单个查询的时候，你要先复制一个单词，然后再点击按钮查 ...

刚试了下，确实如此。
Check表格 不输入单词按批量查询 有道不出错，必应会弹窗报错。建议把报错改成提示比较好。

infox

addision 发表于 2018-10-13 09:19
请查看动图，4个按钮在2016下测试没问题

详细请参考
链接: https://pan.baidu.com/s/1c0bkp9EcSCmDyNKSGg7hmA 提取码: 1111

感觉手上的表格和你的不太一样，必应好像没有道好用。

諦覠

楼主，这个怎么使用呢

文西思密达

諦覠 发表于 2018-10-11 09:42
楼主，这个怎么使用呢

放上你需要查询的音标到A列，然后点击有道接口  或者 必应 接口 即可，可以查看原贴

tuimodewenzi

好牛的样子~！！~~！·

uu刘壮实

感谢大佬无私奉献  收藏了

teondy

感谢分享！！！

QZMASE

好像很厉害的样子，谢谢楼主分享

chinaidehua

真的是个有心人！！！

lovelw17

        谢谢@Thanks！

金龙影子

下载试试看！