用excel上網查音標又掛了

帖子: 2
主題: 0
精華: 0
積分: 7
點名: 0
作業系統: Windows
軟體版本: 7.0
閱讀權限: 10
註冊時間: 2012-11-15
最後登錄: 2021-11-2

11^# 跳轉到 »

發表於 2013-2-2 00:29 | 只看該作者

Sub searchITxx(rng As Range)
Dim XH As Object
Dim iurl, iurl2 As String
iurl = "http://tw.dictionary.search.yahoo.com/search?p="
iurl2 = "http://dict.tw/index.pl?query="
With rng.EntireRow
 .Resize(1, .Columns.Count - 1).Offset(0, 1).Clear
End With
'開啟網頁
Set XH = CreateObject("Microsoft.XMLHTTP")
With XH
 .Open "get", iurl & rng, False
 .send

 On Error Resume Next
 '從Yahoo字典摘取第一組中文翻譯
 rng.Offset(0, 2) = Split(Split(.responseText, "")(1), "<")(0)

 '摘取KK音標
 rng.Offset(0, 1).Font.Name = "Arial Unicode MS"
 rng.Offset(0, 1).Size = 12
 rng.Offset(0, 1) = VBA.Split(VBA.Split(.responseText, """proun_value"">")(1), "<")(0)

 .Open "get", iurl2 & rng, False
 .send
 '從DICT.TW 英漢字典擷取字義
 rng.Offset(0, 3) = Split(Split(.responseText, "  ")(1), "<")(0)

End With

End Sub

TOP

cautionkimo

小學生 Rank: 1

帖子: 2
主題: 0
精華: 0
積分: 7
點名: 0
作業系統: Windows
軟體版本: 7.0
閱讀權限: 10
註冊時間: 2012-11-15
最後登錄: 2021-11-2

12^#

發表於 2013-2-2 00:32 | 只看該作者

Sub 按鈕268_Click()

Columns("B:B").Select
With Selection.Font
 .Name = "Arial Unicode MS"
 .Size = 12
End With
Range("a1").Select

Dim XH As Object

Dim rng As Range

 Dim iurl, iurl2 As String
'清除已有的解釋及音標
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("a65536").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, 2) = Split(Split(.responseText, "")(1), "<")(0)
 '摘取KK音標
 rng.Offset(0, 1) = Left(VBA.Split(.responseText, """proun_value"">")(1), InStr(VBA.Split(.responseText, """proun_value"">")(1), "]"))
 .Open "get", iurl2 & rng, False
 .send
 '從DICT.TW 英漢字典擷取字義
 rng.Offset(0, 3) = Split(Split(.responseText, "  ")(1), "<")(0)
 End With
 End If
Next

End Sub
不要叫我高手

TOP

自我感覺良好