返回列表 上一主題 發帖

用excel上網查音標 又掛了

用excel上網查音標 又掛了

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

001.JPG (140.33 KB)

001.JPG

50 字節以內
不支持自定義 Discuz! 代碼

回復 12# cautionkimo


    Dim rng .......Next
更好用
管你多少個單字
一鍵都搞定了
50 字節以內
不支持自定義 Discuz! 代碼

TOP

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, "<p class=""explanation"">")(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, "</span><br /> &nbsp;")(1), "<")(0)
                    End With
             End If
    Next
   
End Sub
不要叫我高手

TOP

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, "<p class=""explanation"">")(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, "</span><br /> &nbsp;")(1), "<")(0)
        
    End With
   
End Sub

TOP

哈哈 我又來了
反正作自己有興趣的事情囉


查字典02
50 字節以內
不支持自定義 Discuz! 代碼

TOP

  1. Sub searchIT(Rng As Range)
  2.     Dim XH As Object
  3.     Dim shpRm As Shape
  4.     Dim iurl, iurl2 As String
  5.     '清除已有的解釋及音標
  6.     iurl = "http://tw.dictionary.search.yahoo.com/search?p="
  7.     iurl2 = "http://dict.tw/index.pl?query="
  8.     With Rng.EntireRow
  9.         .Resize(1, .Columns.Count - 1).Offset(0, 1).Clear
  10.     End With
  11.     '開啟網頁
  12.     Set XH = CreateObject("Microsoft.XMLHTTP")
  13.     With XH


  14.         .Open "get", iurl & Rng, False
  15.       
  16.         
  17.         .send
  18.         On Error Resume Next
  19.         '從Yahoo字典摘取第一組中文翻譯
  20.         'Rng.Offset(0, 2) = Split(Split(.responseText, "<ol class=""explanation_ol""><li ><p class=""explanation"">")(1), "<")(0)
  21.         Rng.Offset(0, 2) = Split(Split(.responseText, "<p class=""explanation"">")(1), "<")(0)
  22.         '摘取KK音標
  23.         'Rng.Offset(0, 1) = Left(VBA.Split(.responseText, "KK</span><span class=""proun_value"">")(1), InStr(VBA.Split(.responseText, "KK</span><span class=""proun_value"">")(1), "]"))
  24.          Rng.Offset(0, 1) = Left(VBA.Split(.responseText, """proun_value"">")(1), InStr(VBA.Split(.responseText, """proun_value"">")(1), "]"))
  25.         .Open "get", iurl2 & Rng, False
  26.         .send
  27.         '從DICT.TW 英漢字典擷取字義
  28.         Rng.Offset(0, 3) = Split(Split(.responseText, "</span><br /> &nbsp;")(1), "<")(0)
  29.         
  30.     End With
  31.    
  32. End Sub
複製代碼
查字001.rar (25.32 KB)
download it
50 字節以內
不支持自定義 Discuz! 代碼

TOP

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



哈哈 老實跟你說 我也不懂程式語法 無中生有是不行....
不過遇到有興趣的   就土法煉鋼給他練...多嘗試就出來..別怕遇到困難....享受解決問題的樂趣囉.
50 字節以內
不支持自定義 Discuz! 代碼

TOP

感恩!太感謝了。
只是不知那一天
yahoo又要開偶的玩笑……
50 字節以內
不支持自定義 Discuz! 代碼

TOP

回復 5# 自我感覺良好

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

   
50 字節以內
不支持自定義 Discuz! 代碼

TOP

查字001.rar (19 KB)
我還是小朋友無法下載檔案
附上檔案幫我看看那裡出錯了
我查單字都會出現
<span class="proun_value">:Q

often        <span class="proun_value">[ˋɔfən]
public        <span class="proun_value">[ˋpʌblɪk]
airport        <span class="proun_value">[ˋɛr͵port]
       
       
airplane        <span class="proun_value">[ˋɛr͵plen]
system        <span class="proun_value">[ˋsɪstəm]
protect        <span class="proun_value">[prəˋtɛkt]
50 字節以內
不支持自定義 Discuz! 代碼

TOP

        靜思自在 : 有願放在心裡,沒有身體力行,正如耕田不播種,皆是空過因緣。
返回列表 上一主題