返回列表 上一主題 發帖

上網查音標英英解釋

上網查音標英英解釋

剛剛爬了一下文
用錯的程式碼出現了VB編輯器
這樣我照著試試,成功了


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


我試著改動程式碼但沒有任何反應
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

回復 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
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

回復 2# stillfish00

謝謝前輩指導
我研究了一下
仍出現這樣的錯誤訊息

請問我哪裡做錯了嗎?
dict Eng.zip (15.72 KB)
附件是我研究後的結果,請前輩指導。

請問可否推薦VB的入門書籍?試錯後覺得很有趣想瞭解,謝謝各位前輩。

TOP

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

網頁擷取相關的就算是進階書也不會教你的
入門書到書店翻翻看適合自己程度的會比較好。
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

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

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

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

TOP

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

回復 3# brianhau
亦可以援用原本的方式,即
使用分別之兩個自訂函式:
  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
複製代碼
  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
複製代碼
如此結果應該是你構想的方式了。

TOP

回復 4# stillfish00
謝謝stillfish00的回覆
但我還試試不出來...

TOP

回復 6# c_c_lai
謝謝c_c_lai,非常感激!
我試著貼上程式碼,發現完全不會動作,是欠缺什麼步驟嗎?
再次謝謝您!
dict Eng.rar (12.03 KB)

TOP

回復 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』。

TOP

回復 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) 即可。

TOP

        靜思自在 : 心中常存善解、包容、感思、知足、惜福。
返回列表 上一主題