上網查音標英英解釋

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

11^# 跳轉到 »

發表於 2015-12-28 19:34 | 只看該作者

回復 8# brianhau

Option Explicit
Private oxmlhttp As Object
Private ohtml As Object
Sub Ex()
Dim txt As String
' txt = dictionary_oxford("simulation")
' MsgBox "simulation = " & txt
' searchITA ([A1])
searchIT ([A1])
End Sub
Function dictionary_oxford(word As String)
Dim colNodes As Object, bFound As Boolean, x As Variant
If oxmlhttp Is Nothing Then Set oxmlhttp = CreateObject("msxml2.xmlhttp")
If ohtml Is Nothing Then Set ohtml = CreateObject("htmlfile")
With oxmlhttp
.Open "get", "http://www.oxfordlearnersdictionaries.com/definition/english/" & word, False
.send
ohtml.body.innerhtml = .responseText
' <span class="def" ...
Set colNodes = ohtml.getElementsByTagName("span")
For Each x In colNodes
If x.className = "def" Then bFound = True: dictionary_oxford = x.innerText: Exit For
Next
If Not bFound Then dictionary_oxford = "# Not Found #"
End With
End Function
Function searchIT(rng As Range)
Dim XH As Object, shpRm As Shape
Dim iurl, iurl2 As String
Columns("B:B").Select
With Selection.Font
.Name = "Arial Unicode MS"
.Size = 12
End With
Range("B:J").Clear
' Range("a1").Select
rng.Select
' 清除已有的解釋及音標
iurl = "http://tw.dictionary.search.yahoo.com/search?p="
iurl2 = "http://dict.tw/index.pl?query="
For Each rng In ActiveSheet.Range("a1", ActiveSheet.Range("A" & Rows.Count).End(xlUp))
rng.Select
If rng.Value <> "" Then
rng.Select
Set XH = CreateObject("Microsoft.XMLHTTP")
With XH
.Open "get", iurl & rng, False
.send
' On Error Resume Next
' 從Yahoo字典摘取第一組中文翻譯
' rng.Offset(0, 20) = .responseText
rng.Offset(0, 20) = ""
If InStr(.responseText, "><h4>1.") > 0 Then rng.Offset(0, 2) = Trim(Split(Split(.responseText, "><h4>1.")(1), "<")(0))
' 摘取KK音標
If InStr(.responseText, ">KK[") > 0 Then rng.Offset(0, 1) = "[" & Split(Split(.responseText, ">KK[")(1), "]")(0) & "]"
.Open "get", iurl2 & rng, False
.send
' 從DICT.TW 英漢字典擷取字義
If InStr(.responseText, "</span><br />  ") > 0 Then rng.Offset(0, 3) = Split(Split(.responseText, "</span><br />  ")(1), "<")(0)
End With
rng.Offset(0, 9) = dictionary_oxford(rng.Value)
End If
Next
End Function
Function searchITA(rng As Range)
Dim XH As Object, shpRm As Shape
Dim iurl, iurl2 As String, x As Variant
Dim colNodes As Object, bFound As Boolean, oxford As String
Columns("B:B").Select
With Selection.Font
.Name = "Arial Unicode MS"
.Size = 12
End With
' 清除已有的解釋及音標
Range("B:J").Clear
' Range("a1").Select
rng.Select
iurl = "http://tw.dictionary.search.yahoo.com/search?p="
iurl2 = "http://dict.tw/index.pl?query="
For Each rng In ActiveSheet.Range("a1", ActiveSheet.Range("A" & Rows.Count).End(xlUp))
rng.Select
If rng.Value <> "" Then
rng.Select
Set XH = CreateObject("Microsoft.XMLHTTP")
With XH
.Open "get", iurl & rng, False
.send
' On Error Resume Next
' 從Yahoo字典摘取第一組中文翻譯
If InStr(.responseText, "><h4>1.") > 0 Then rng.Offset(0, 2) = Trim(Split(Split(.responseText, "><h4>1.")(1), "<")(0))
' 摘取KK音標
If InStr(.responseText, ">KK[") > 0 Then rng.Offset(0, 1) = "[" & Split(Split(.responseText, ">KK[")(1), "]")(0) & "]"
.Open "get", iurl2 & rng, False
.send
' 從 DICT.TW 英漢字典擷取字義
If InStr(.responseText, "</span><br />  ") > 0 Then rng.Offset(0, 3) = Split(Split(.responseText, "</span><br />  ")(1), "<")(0)
End With
If oxmlhttp Is Nothing Then Set oxmlhttp = CreateObject("msxml2.xmlhttp")
If ohtml Is Nothing Then Set ohtml = CreateObject("htmlfile")
With oxmlhttp
.Open "get", "http://www.oxfordlearnersdictionaries.com/definition/english/" & rng, False
.send
ohtml.body.innerhtml = .responseText
' <span class="def" ...
Set colNodes = ohtml.getElementsByTagName("span")
For Each x In colNodes
If x.className = "def" Then bFound = True: oxford = x.innerText: Exit For
Next
If Not bFound Then oxford = "# Not Found #"
End With
rng.Offset(0, 9) = oxford
End If
Next
End Function