英语学习小工具-取音释义 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, 下载次数: 84)

2018-10-11 11:48 上传

点击文件名下载附件

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

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

 
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！

金龙影子

下载试试看！