Board logo

標題: 用excel上網查音標 [打印本頁]
作者: 自我感覺良好    時間: 2010-7-22 09:08     標題: 用excel上網查音標

本帖最後由 Hsieh 於 2010-7-22 13:04 編輯

http://gb.twbts.com/index.php?topic=11456.10


http://www.boxcn.net/shared/77cyt18g34
crdotlin 版主做的。

舊版的excel主題: 單字(詞)學習工具 曾討論過的,用excel上網查音標。
只是現在yahoo的網頁改變了
請問現在要怎麼用呢!
作者: Hsieh    時間: 2010-7-22 13:10

本帖最後由 Hsieh 於 2010-7-22 13:11 編輯

回復 1# 自我感覺良好


   現在的yahoo字典音標已經改成文字
這樣更好辨識了
  1. Sub searchIT(Rng As Range)
  2.     Dim XH As Object
  3.     Dim shpRm As Shape
  4.     '清除已有的解釋及音標
  5.     With Rng.EntireRow
  6.         .Resize(1, .Columns.Count - 1).Offset(0, 1).Clear
  7.     End With
  8.     '開啟網頁
  9.     Set XH = CreateObject("Microsoft.XMLHTTP")
  10.     With XH
  11.         .Open "get", "http://tw.dictionary.yahoo.com/dictionary?p=" & Rng.Text, False
  12.         .send
  13.         On Error Resume Next
  14.         '摘取第一組中文翻譯
  15.         Rng.Offset(0, 2) = Split(Split(.responseText, "class=""description""><p>1.")(1), "<")(0)
  16.         '摘取KK音標
  17.         Rng.Offset(0, 1) = Left(VBA.Split(.responseText, "KK</span>  ")(1), InStr(VBA.Split(.responseText, "KK</span>  ")(1), "]"))
  18.         
  19.     End With
  20.     Rng.Select
  21. End Sub
複製代碼
[attach]1929[/attach]
作者: 自我感覺良好    時間: 2010-7-22 16:31

回復 2# Hsieh
真的太感謝了,又可以查音標了。
    I        [aɪ]
am        [æm]
really        [ˋrɪəlɪ]
thankful        [ˋθæŋkfəl]
作者: uncle    時間: 2011-10-26 18:59

回復 2# Hsieh


    我是新會員還不能下載檔案。小弟不才，請問這些代碼要如何使用?
作者: dechiuan999    時間: 2011-11-21 09:13

各位大大好：

    又有一個學習英文的
好工具，小弟要好好多加
運用。可是小弟在學習過程
中一直無法顯示其音標。
請問其原因為何呢？

感恩各位大大！
作者: GBKEE    時間: 2011-11-21 10:02

回復 6# dechiuan999
2樓    摘取KK音標  這行程式碼
          Rng.Offset(0, 1) = Left(VBA.Split(.responseText, "KK</span>  ")(1), InStr(VBA.Split(.responseText, "KK</span>  ")(1), "]"))
         修改為
         Rng.Offset(0, 1) = Split((Split(.responseText, "KK</span>")(1)), "<span>")(0)
作者: dechiuan999    時間: 2011-11-21 13:53

謝謝版主大大。
已測試可以應用了。
希望借用此功能可以
讓自已的英文有所進步。

感恩大大！
作者: james123    時間: 2014-11-16 17:02

看起來是一個好玩的軟體~~
載來玩玩
作者: wufonna    時間: 2014-11-17 14:26

回復 2# Hsieh


    請問 版主如下錯誤是如何，謝謝
[attach]19560[/attach][attach]19561[/attach]
作者: mmxxxx    時間: 2014-11-18 14:52

回復 9# wufonna


我也是相同問題，使用環境Win 7, MS Office 2010.
好可惜，功能很棒，請大大協助。
作者: jimjim    時間: 2016-1-26 10:16

我也是一樣的問題 卡在send,請問如何處理
作者: c_c_lai    時間: 2016-1-26 13:40

本帖最後由 c_c_lai 於 2016-1-26 13:41 編輯

回復 1# 自我感覺良好
回復 2# Hsieh
回復 6# GBKEE
  1. Option Explicit

  3. Sub searchIT(Rng As Range)
  4.     Dim XH As Object
  5.     Dim shpRm As Shape
  6.    
  7.     '  清除已有的解釋及音標
  8.     With Rng.EntireRow
  9.         .Resize(1, .Columns.Count - 1).Offset(0, 1).Clear
  10.     End With
  11.    
  12.     '  開啟網頁
  13.     Set XH = CreateObject("Microsoft.XMLHTTP")
  14.     With XH
  15.         .Open "get", "http://tw.dictionary.search.yahoo.com/search?p=" & Rng.Text, False
  16.         .send
  17.         On Error Resume Next
  18.         '  摘取第一組中文翻譯
  19.         '  Rng.Offset(0, 2) = Split(Split(.responseText, "class=""description""><p>1.")(1), "<")(0)
  20.         If InStr(.responseText, "><h4>1.") > 0 Then Rng.Offset(0, 2) = Trim(Split(Split(.responseText, "><h4>1.")(1), "<")(0))
  21.         '  摘取KK音標
  22.         '  Rng.Offset(0, 1) = Left(VBA.Split(.responseText, "KK</span>  ")(1), InStr(VBA.Split(.responseText, "KK</span>  ")(1), "]"))
  23.         '  Rng.Offset(0, 1) = Split((Split(.responseText, "KK</span>")(1)), "<span>")(0)
  24.         If InStr(.responseText, ">KK[") > 0 Then Rng.Offset(0, 1) = "[" & Split(Split(.responseText, ">KK[")(1), "]")(0) & "]"
  25.     End With
  26.    
  27.     Rng.Select
  28. End Sub

  30. Sub Ex()
  31.     Dim Rng As Range
  32.    
  33.     For Each Rng In ActiveSheet.Range("A1", ActiveSheet.Range("A" & Rows.Count).End(xlUp))
  34.         Rng.Select
  35.         If Rng.Value <> "" Then
  36.             searchIT Rng
  37.         End If
  38.     Next
  39. End Sub
複製代碼




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