麻辣家族討論版版 - Powered by Discuz! Board

標題: 用excel上網查音標又掛了 [打印本頁]

作者: 自我感覺良好 時間: 2012-11-30 07:30 標題: 用excel上網查音標又掛了

用excel上網查音標又掛了
可能網頁改變…
查不出原因
煩請各位大大幫幫忙

作者: softsadwind 時間: 2012-11-30 14:16

[attach]13343[/attach]

Private Sub CommandButton1_Click()
Dim XH As Object
Dim shpRm As Shape
' With Rng.EntireRow
' .Resize(1, .Columns.Count - 1).Offset(0, 1).Clear
'End With
Dim i
With Range(Range("A1"), Range("A1").End(xlDown))
For i = .Columns(1).Rows.Count To 2 Step -1
If .Cells(i, 1).Value <> "" Then
Set Rng = Cells(i, 1)
Set XH = CreateObject("Microsoft.XMLHTTP")
With XH
.Open "get", "http://tw.dictionary.yahoo.com/dictionary?p=" & Rng.Text, False
.send
On Error Resume Next
Rng.Offset(0, 2) = Split(Split(.responseText, "class=""description"">1.")(1), "<")(0)
Rng.Offset(0, 1) = Left(VBA.Split(.responseText, "KK")(1), InStr(VBA.Split(.responseText, "KK")(1), "]"))
End With
Else
End If
Next
End With
End Sub

複製代碼

作者: 自我感覺良好 時間: 2012-11-30 15:59

奇怪呢!還是不能用.....

作者: softsadwind 時間: 2012-11-30 23:47

我自己回家用ie9 上面的程式也不行...
把網址改一下就好了.....

.Open "get", "http://tw.dictionary.search.yahoo.com/search?p=" & Rng, False

複製代碼

[attach]13346[/attach]

作者: 自我感覺良好 時間: 2012-12-1 06:21

[attach]13348[/attach]
我還是小朋友無法下載檔案
附上檔案幫我看看那裡出錯了
我查單字都會出現
:Q

often [ˋɔfən]
public [ˋpʌblɪk]
airport [ˋɛr͵port]

airplane [ˋɛr͵plen]
system [ˋsɪstəm]
protect [prəˋtɛkt]

作者: softsadwind 時間: 2012-12-1 08:56

回復 5# 自我感覺良好

去下載囉
https://www.dropbox.com/s/lxz2rycl53ax2cc/%E6%9F%A5%E5%AD%97001.xlsm

[attach]13350[/attach]

作者: 自我感覺良好 時間: 2012-12-1 09:38

[attach]13351[/attach]感恩!太感謝了。
只是不知那一天
yahoo又要開偶的玩笑……

作者: softsadwind 時間: 2012-12-1 10:25

感恩!太感謝了。
只是不知那一天
yahoo又要開偶的玩笑……
自我感覺良好發表於 2012-12-1 09:38

哈哈老實跟你說我也不懂程式語法無中生有是不行....
不過遇到有興趣的就土法煉鋼給他練...多嘗試就出來..別怕遇到困難....享受解決問題的樂趣囉.

作者: softsadwind 時間: 2012-12-1 11:14

Sub searchIT(Rng As Range)
Dim XH As Object
Dim shpRm As Shape
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, "<ol class=""explanation_ol""><li >")(1), "<")(0)
Rng.Offset(0, 2) = Split(Split(.responseText, "")(1), "<")(0)
'摘取KK音標
'Rng.Offset(0, 1) = Left(VBA.Split(.responseText, "KK")(1), InStr(VBA.Split(.responseText, "KK")(1), "]"))
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 Sub

複製代碼

[attach]13353[/attach]
download it
[attach]13354[/attach]

作者: softsadwind 時間: 2012-12-1 16:58

哈哈我又來了
反正作自己有興趣的事情囉
[attach]13362[/attach]

查字典02

作者: cautionkimo 時間: 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

作者: cautionkimo 時間: 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
不要叫我高手

作者: 自我感覺良好 時間: 2013-2-2 06:51

回復 12# cautionkimo

Dim rng .......Next
更好用
管你多少個單字
一鍵都搞定了

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)