Board logo

標題: 上網查音標英英解釋 [打印本頁]
作者: brianhau    時間: 2015-12-9 15:19     標題: 上網查音標英英解釋

剛剛爬了一下文
用錯的程式碼出現了VB編輯器
這樣我照著試試，成功了
[attach]22768[/attach]

請教前輩若是我想要插入一欄擷取英英的解釋要怎麼做呢？
例如從
http://www.oxfordlearnersdictionaries.com/definition/english/?q=
中擷取第一行英英解釋
[attach]22769[/attach]

我試著改動程式碼但沒有任何反應
Sub searchIT(rng As Range)
    Dim XH As Object
    Dim shpRm As Shape
    Columns("B:B").Select
    With Selection.Font
        .Name = "Arial Unicode MS"
        .Size = 12
    End With
Range("a1").Select
      Dim iurl, iurl2 As String
    '清除已有的解釋及音標
    iurl = "http://www.oxfordlearnersdictionaries.com/definition/english/?q="
    iurl2 = "http://dict.tw/index.pl?query="
    For Each rng In ActiveSheet.Range("a1", ActiveSheet.Range("a50").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 /> &nbsp;") > 0 Then rng.Offset(0, 3) = Split(Split(.responseText, "</span><br /> &nbsp;")(1), "<")(0)
                    End With
             End If
    Next
End Sub
作者: stillfish00    時間: 2015-12-10 15:36

回復 1# brianhau
用錯的程式碼出現了VB編輯器
這樣我照著試試，成功了

1.  檔案>選項>自訂功能區勾選開發人員，以後就有按鈕直接進去了...
或是快速鍵 Alt+ F11
   
2.  每個網頁都是不一樣的，原程式是針對奇摩字典的網頁分析擷取結果的，你只換網址，分析邏輯都沒變當然不能用...

3.  英英字典的自訂函數
  1. Private oxmlhttp As Object
  2. Private ohtml As Object
  3. Function dictionary_oxford(word As String)
  4.     Dim colNodes As Object, bFound As Boolean
  5.         
  6.     If oxmlhttp Is Nothing Then Set oxmlhttp = CreateObject("msxml2.xmlhttp")
  7.     If ohtml Is Nothing Then Set ohtml = CreateObject("htmlfile")
  8.    
  9.     With oxmlhttp
  10.         .Open "get", "http://www.oxfordlearnersdictionaries.com/definition/english/" & word, False
  11.         .send
  12.         ohtml.body.innerhtml = .responsetext
  13.         
  14.         '<span class="def" ...
  15.         Set colNodes = ohtml.getElementsByTagName("span")
  16.         For Each x In colNodes
  17.             If x.className = "def" Then bFound = True: dictionary_oxford = x.innerText: Exit For
  18.         Next
  19.         If Not bFound Then dictionary_oxford = "# Not Found #"
  20.     End With
  21. End Function
複製代碼
作者: brianhau    時間: 2015-12-11 09:13

回復 2# stillfish00

謝謝前輩指導
我研究了一下
仍出現這樣的錯誤訊息
[attach]22788[/attach]
請問我哪裡做錯了嗎？
[attach]22789[/attach]
附件是我研究後的結果，請前輩指導。

請問可否推薦VB的入門書籍？試錯後覺得很有趣想瞭解，謝謝各位前輩。
作者: stillfish00    時間: 2015-12-11 09:35

回復 3# brianhau
新增新的Module，貼上2# code
工作表 A1 填你要查的字
            B1 填 =dictionary_oxford(A1)

網頁擷取相關的就算是進階書也不會教你的
入門書到書店翻翻看適合自己程度的會比較好。
作者: c_c_lai    時間: 2015-12-11 19:34

本帖最後由 c_c_lai 於 2015-12-12 07:51 編輯

回復 3# brianhau
我將你的程式與 stillfish00 大大的程式碼
略加整合成你的需求：
  1. Private oxmlhttp As Object
  2. Private ohtml As Object

  4. Function searchITA(rng As Range)
  5.     Dim XH As Object, shpRm As Shape
  6.     Dim iurl, iurl2 As String
  7.     Dim colNodes As Object, bFound As Boolean, oxford As String
  8.      
  9.     Columns("B:B").Select
  10.     With Selection.Font
  11.          .Name = "Arial Unicode MS"
  12.          .Size = 12
  13.     End With
  14.     '  清除已有的解釋及音標
  15.     Range("B:J").Clear
  16.     Range("a1").Select
  17.      
  18.     iurl = "http://tw.dictionary.search.yahoo.com/search?p="
  19.     iurl2 = "http://dict.tw/index.pl?query="
  20.     For Each rng In ActiveSheet.Range("a1", ActiveSheet.Range("a50").End(xlUp))
  21.         rng.Select
  22.         If rng.Value <> "" Then
  23.             rng.Select
  24.             Set XH = CreateObject("Microsoft.XMLHTTP")
  25.             With XH
  26.                 .Open "get", iurl & rng, False
  27.                 .send
  28.                 '  On Error Resume Next
  29.                 '  從Yahoo字典摘取第一組中文翻譯
  30.                  If InStr(.responseText, "><h4>1.") > 0 Then rng.Offset(0, 2) = Trim(Split(Split(.responseText, "><h4>1.")(1), "<")(0))
  31.                 '  摘取KK音標
  32.                 If InStr(.responseText, ">KK[") > 0 Then rng.Offset(0, 1) = "[" & Split(Split(.responseText, ">KK[")(1), "]")(0) & "]"
  33.                 .Open "get", iurl2 & rng, False
  34.                 .send
  35.                 '  從 DICT.TW 英漢字典擷取字義
  36.                 If InStr(.responseText, "</span><br /> &nbsp;") > 0 Then rng.Offset(0, 3) = Split(Split(.responseText, "</span><br /> &nbsp;")(1), "<")(0)
  37.             End With
  38.             If oxmlhttp Is Nothing Then Set oxmlhttp = CreateObject("msxml2.xmlhttp")
  39.             If ohtml Is Nothing Then Set ohtml = CreateObject("htmlfile")
  40.    
  41.             With oxmlhttp
  42.                 .Open "get", "http://www.oxfordlearnersdictionaries.com/definition/english/" & rng, False
  43.                 .send
  44.                 ohtml.body.innerhtml = .responseText
  45.         
  46.                 '  <span class="def" ...
  47.                 Set colNodes = ohtml.getElementsByTagName("span")
  48.                 For Each x In colNodes
  49.                     If x.className = "def" Then bFound = True: oxford = x.innerText: Exit For
  50.                 Next
  51.                 If Not bFound Then oxford = "# Not Found #"
  52.            End With
  53.            rng.Offset(0, 9) = oxford
  54.         End If
  55.     Next
  56. End Function
複製代碼
  1. Sub Ex()
  2.     searchITA ([A1])
  3. End Sub
複製代碼
作者: c_c_lai    時間: 2015-12-11 20:12

本帖最後由 c_c_lai 於 2015-12-14 07:33 編輯

回復 3# brianhau
亦可以援用原本的方式，即
使用分別之兩個自訂函式：
  1. Private oxmlhttp As Object
  2. Private ohtml As Object

  4. Function dictionary_oxford(word As String)
  5.     Dim colNodes As Object, bFound As Boolean
  6.         
  7.     If oxmlhttp Is Nothing Then Set oxmlhttp = CreateObject("msxml2.xmlhttp")
  8.     If ohtml Is Nothing Then Set ohtml = CreateObject("htmlfile")
  9.    
  10.     With oxmlhttp
  11.         .Open "get", "http://www.oxfordlearnersdictionaries.com/definition/english/" & word, False
  12.         .send
  13.         ohtml.body.innerhtml = .responseText
  14.         
  15.         '  <span class="def" ...
  16.         Set colNodes = ohtml.getElementsByTagName("span")
  17.         For Each x In colNodes
  18.             If x.className = "def" Then bFound = True: dictionary_oxford = x.innerText: Exit For
  19.         Next
  20.         If Not bFound Then dictionary_oxford = "# Not Found #"
  21.     End With
  22. End Function
複製代碼
  1. Sub Ex()
  2.     Dim txt As String
  3.    
  4.     '  txt = dictionary_oxford("simulation")
  5.     '  MsgBox "simulation = " & txt
  6.     searchIT ([A1])
  7. End Sub
複製代碼
  1. Function searchIT(rng As Range)
  2.     Dim XH As Object, shpRm As Shape
  3.     Dim iurl, iurl2 As String
  4.      
  5.     Columns("B:B").Select
  6.     With Selection.Font
  7.          .Name = "Arial Unicode MS"
  8.          .Size = 12
  9.     End With
  10.    
  11.     Range("B:J").Clear
  12.     Range("a1").Select
  13.     '  清除已有的解釋及音標
  14.     iurl = "http://tw.dictionary.search.yahoo.com/search?p="
  15.     iurl2 = "http://dict.tw/index.pl?query="
  16.     For Each rng In ActiveSheet.Range("a1", ActiveSheet.Range("a50").End(xlUp))
  17.         rng.Select
  18.         If rng.Value <> "" Then
  19.             rng.Select
  20.             Set XH = CreateObject("Microsoft.XMLHTTP")
  21.             With XH
  22.                 .Open "get", iurl & rng, False
  23.                 .send
  24.                 '  On Error Resume Next
  25.                 '  從Yahoo字典摘取第一組中文翻譯
  26.                 If InStr(.responseText, "><h4>1.") > 0 Then rng.Offset(0, 2) = Trim(Split(Split(.responseText, "><h4>1.")(1), "<")(0))
  27.                 '  摘取KK音標
  28.                 If InStr(.responseText, ">KK[") > 0 Then rng.Offset(0, 1) = "[" & Split(Split(.responseText, ">KK[")(1), "]")(0) & "]"
  29.                 .Open "get", iurl2 & rng, False
  30.                 .send
  31.                 '  從DICT.TW 英漢字典擷取字義
  32.                 If InStr(.responseText, "</span><br /> &nbsp;") > 0 Then rng.Offset(0, 3) = Split(Split(.responseText, "</span><br /> &nbsp;")(1), "<")(0)
  33.             End With
  34.             rng.Offset(0, 9) = dictionary_oxford(rng.Value)
  35.         End If
  36.     Next
  37. End Function
複製代碼
如此結果應該是你構想的方式了。
作者: brianhau    時間: 2015-12-28 11:44

回復 4# stillfish00
謝謝stillfish00的回覆
但我還試試不出來...
作者: brianhau    時間: 2015-12-28 11:47

回復 6# c_c_lai
謝謝c_c_lai，非常感激！
我試著貼上程式碼，發現完全不會動作，是欠缺什麼步驟嗎？
再次謝謝您！
[attach]22995[/attach]
作者: c_c_lai    時間: 2015-12-28 18:49

回復 8# brianhau
你目前的『模組』分別為 Module1、Module2、Module3，
以下是你目前程式放置的內容：
Module1 擺放的是 Function dictionary_oxford(word As String)，
Module2 擺放的是 Sub Ex() 測試模組 (主程式)，
Module3 擺放的是 Function searchIT(rng As Range)
你只要執行 『模組 -> Module2 -> Ex』就行了。
或者是 (正式運作時)
你可以插入『Button』物件，指到你的 『模組 -> Module2 -> Ex』。
作者: c_c_lai    時間: 2015-12-28 18:53

回復 8# brianhau
如前面所述，你可以選擇執行
(A) searchIT ([A1]) 亦或是
(B) searchITA ([A1])。

(A) 模式係將函示分為兩個函式處裡不同內容：
    A-1.  Function searchIT(rng As Range)
          從 Yahoo 字典摘取第一組 KK 音標、中文翻譯
    A-2.  Function dictionary_oxford(word As String)
          抓取對應之牛津英辭解釋。
(B) 模式係將函示合而為一，以一個函式處裡 A-1 以及 A-2
    不同作業內容：
    B.  Function searchITA(rng As Range)

擇一執行，可依你個人喜好選擇，A 案係依處裡不同內容，而
有其各自的函式包裝，事後可依其它實務需求易於組合包裝；
B 案係為整合式函式。)

你可將程式全部置放於『模組 -> Module1』內，或是將 Ex()
單獨抽出來另放置在 ThisWorkbook 的程式碼區內；或者是
將所有程式碼全部裝置在  ThisWorkbook 的程式碼區內。

在程式碼最前面如果你加入了 『Option Explicit』，
意即你宣告了所有使用之變數需應「事先加以宣告」的原因。
因為在 dictionary_oxford 函式並未宣告 x 的變數型態，
你只要加入型態宣告 (x As Variant) 即可。
作者: c_c_lai    時間: 2015-12-28 19:34

回復 8# brianhau
  1. Option Explicit

  3. Private oxmlhttp As Object
  4. Private ohtml As Object

  6. Sub Ex()
  7.     Dim txt As String
  8.    
  9.     '  txt = dictionary_oxford("simulation")
  10.     '  MsgBox "simulation = " & txt
  11.     '  searchITA ([A1])
  12.     searchIT ([A1])
  13. End Sub

  15. Function dictionary_oxford(word As String)
  16.     Dim colNodes As Object, bFound As Boolean, x As Variant
  17.         
  18.     If oxmlhttp Is Nothing Then Set oxmlhttp = CreateObject("msxml2.xmlhttp")
  19.     If ohtml Is Nothing Then Set ohtml = CreateObject("htmlfile")
  20.    
  21.     With oxmlhttp
  22.         .Open "get", "http://www.oxfordlearnersdictionaries.com/definition/english/" & word, False
  23.         .send
  24.         ohtml.body.innerhtml = .responseText
  25.         
  26.         '  <span class="def" ...
  27.         Set colNodes = ohtml.getElementsByTagName("span")
  28.         For Each x In colNodes
  29.             If x.className = "def" Then bFound = True: dictionary_oxford = x.innerText: Exit For
  30.         Next
  31.         If Not bFound Then dictionary_oxford = "# Not Found #"
  32.     End With
  33. End Function

  35. Function searchIT(rng As Range)
  36.     Dim XH As Object, shpRm As Shape
  37.     Dim iurl, iurl2 As String
  38.      
  39.     Columns("B:B").Select
  40.     With Selection.Font
  41.          .Name = "Arial Unicode MS"
  42.          .Size = 12
  43.     End With
  44.    
  45.     Range("B:J").Clear
  46.     '  Range("a1").Select
  47.     rng.Select
  48.     '  清除已有的解釋及音標
  49.     iurl = "http://tw.dictionary.search.yahoo.com/search?p="
  50.     iurl2 = "http://dict.tw/index.pl?query="
  51.     For Each rng In ActiveSheet.Range("a1", ActiveSheet.Range("A" & Rows.Count).End(xlUp))
  52.         rng.Select
  53.         If rng.Value <> "" Then
  54.             rng.Select
  55.             Set XH = CreateObject("Microsoft.XMLHTTP")
  56.             With XH
  57.                 .Open "get", iurl & rng, False
  58.                 .send
  59.                 '  On Error Resume Next
  60.                 '  從Yahoo字典摘取第一組中文翻譯
  61.                 '  rng.Offset(0, 20) = .responseText
  62.                 rng.Offset(0, 20) = ""
  63.                 If InStr(.responseText, "><h4>1.") > 0 Then rng.Offset(0, 2) = Trim(Split(Split(.responseText, "><h4>1.")(1), "<")(0))
  64.                 '  摘取KK音標
  65.                 If InStr(.responseText, ">KK[") > 0 Then rng.Offset(0, 1) = "[" & Split(Split(.responseText, ">KK[")(1), "]")(0) & "]"
  66.                 .Open "get", iurl2 & rng, False
  67.                 .send
  68.                 '  從DICT.TW 英漢字典擷取字義
  69.                 If InStr(.responseText, "</span><br /> &nbsp;") > 0 Then rng.Offset(0, 3) = Split(Split(.responseText, "</span><br /> &nbsp;")(1), "<")(0)
  70.             End With
  71.             rng.Offset(0, 9) = dictionary_oxford(rng.Value)
  72.         End If
  73.     Next
  74. End Function

  76. Function searchITA(rng As Range)
  77.     Dim XH As Object, shpRm As Shape
  78.     Dim iurl, iurl2 As String, x As Variant
  79.     Dim colNodes As Object, bFound As Boolean, oxford As String
  80.      
  81.     Columns("B:B").Select
  82.     With Selection.Font
  83.          .Name = "Arial Unicode MS"
  84.          .Size = 12
  85.     End With
  86.     '  清除已有的解釋及音標
  87.     Range("B:J").Clear
  88.     '  Range("a1").Select
  89.     rng.Select
  90.      
  91.     iurl = "http://tw.dictionary.search.yahoo.com/search?p="
  92.     iurl2 = "http://dict.tw/index.pl?query="
  93.     For Each rng In ActiveSheet.Range("a1", ActiveSheet.Range("A" & Rows.Count).End(xlUp))
  94.         rng.Select
  95.         If rng.Value <> "" Then
  96.             rng.Select
  97.             Set XH = CreateObject("Microsoft.XMLHTTP")
  98.             With XH
  99.                 .Open "get", iurl & rng, False
  100.                 .send
  101.                 '  On Error Resume Next
  102.                 '  從Yahoo字典摘取第一組中文翻譯
  103.                 If InStr(.responseText, "><h4>1.") > 0 Then rng.Offset(0, 2) = Trim(Split(Split(.responseText, "><h4>1.")(1), "<")(0))
  104.                 '  摘取KK音標
  105.                 If InStr(.responseText, ">KK[") > 0 Then rng.Offset(0, 1) = "[" & Split(Split(.responseText, ">KK[")(1), "]")(0) & "]"
  106.                 .Open "get", iurl2 & rng, False
  107.                 .send
  108.                 '  從 DICT.TW 英漢字典擷取字義
  109.                 If InStr(.responseText, "</span><br /> &nbsp;") > 0 Then rng.Offset(0, 3) = Split(Split(.responseText, "</span><br /> &nbsp;")(1), "<")(0)
  110.             End With
  111.             If oxmlhttp Is Nothing Then Set oxmlhttp = CreateObject("msxml2.xmlhttp")
  112.             If ohtml Is Nothing Then Set ohtml = CreateObject("htmlfile")
  113.    
  114.             With oxmlhttp
  115.                 .Open "get", "http://www.oxfordlearnersdictionaries.com/definition/english/" & rng, False
  116.                 .send
  117.                 ohtml.body.innerhtml = .responseText
  118.         
  119.                 '  <span class="def" ...
  120.                 Set colNodes = ohtml.getElementsByTagName("span")
  121.                 For Each x In colNodes
  122.                     If x.className = "def" Then bFound = True: oxford = x.innerText: Exit For
  123.                 Next
  124.                 If Not bFound Then oxford = "# Not Found #"
  125.            End With
  126.            rng.Offset(0, 9) = oxford
  127.         End If
  128.     Next
  129. End Function
複製代碼
作者: brianhau    時間: 2016-1-11 17:47

回復 11# c_c_lai


    感謝！真的非常感謝你！
成功了！
我想您說的很清楚，但我看不大懂，需要好好消化一番！
作者: nichchen    時間: 2016-3-22 16:31

我用上面的程式碼,上周大部份都可成功,但從上周六開始出現錯誤訊息,Run-time error '1004",請問高手,有好方法嗎? 下面二個平台版本,出現的狀況都一樣

Windows 7+office 2010
Windows 10+office 2010



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