吾爱破解 - LCG - LSG |安卓破解|病毒分析|www.52pojie.cn

 找回密码
 注册[Register]

QQ登录

只需一步,快速开始

查看: 5683|回复: 43
收起左侧

[其他原创] 英语学习小工具-取音释义 V1.3

  [复制链接]
文西思密达 发表于 2018-10-11 09:38
本帖最后由 addision 于 2018-10-13 09:18 编辑

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


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


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

测试环境:Office2010 x32   Office2016 x32  Office365无问题

低版本的朋友,建议升级

-------------------------------------------动图说明--------------------------------------------------------
GIF.gif


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

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




免费评分

参与人数 10吾爱币 +11 热心值 +10 收起 理由
admh + 1 谢谢@Thanks!
温柔xxx + 1 + 1 谢谢@Thanks!
wushaominkk + 3 + 1 感谢发布原创作品,吾爱破解论坛因你更精彩!
庄胜文 + 1 + 1 用心讨论,共获提升!
king6725 + 1 + 1 谢谢@Thanks!
infox + 1 + 1 热心回复!
showmeone + 1 + 1 我很赞同!
ccccccc444 + 1 + 1 用心讨论,共获提升!
嗨,疯子 + 1 + 1 感觉好高大上
zq8389937 + 1 + 1 这个感觉蛮不错的

查看全部评分

发帖前要善用论坛搜索功能,那里可能会有你要找的答案或者已经有人发布过相同内容了,请勿重复发帖。

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

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

刚试了下,确实如此。
Check表格 不输入单词按批量查询 有道不出错,必应会弹窗报错。建议把报错改成提示比较好。
infox 发表于 2018-10-13 10:43
本帖最后由 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
 楼主| 文西思密达 发表于 2018-10-11 09:45
諦覠 发表于 2018-10-11 09:42
楼主,这个怎么使用呢

放上你需要查询的音标到A列,然后点击有道接口  或者 必应 接口 即可,可以查看原贴
tuimodewenzi 发表于 2018-10-11 09:46
好牛的样子~!!~~!·
uu刘壮实 发表于 2018-10-11 09:50
感谢大佬无私奉献  收藏了
teondy 发表于 2018-10-11 09:55
感谢分享!!!
QZMASE 发表于 2018-10-11 09:57
好像很厉害的样子,谢谢楼主分享
chinaidehua 发表于 2018-10-11 10:04
真的是个有心人!!!
lovelw17 发表于 2018-10-11 10:32
        谢谢@Thanks!
金龙影子 发表于 2018-10-11 10:32
下载试试看!
您需要登录后才可以回帖 登录 | 注册[Register]

本版积分规则 警告:本版块禁止灌水或回复与主题无关内容,违者重罚!

快速回复 收藏帖子 返回列表 搜索

RSS订阅|小黑屋|处罚记录|联系我们|吾爱破解 - LCG - LSG ( 京ICP备16042023号 | 京公网安备 11010502030087号 )

GMT+8, 2024-3-28 22:08

Powered by Discuz!

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表