[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, "æ", 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