12
返回列表 上一主題 發帖

上網查音標英英解釋

brianhau

帖子
6 
主題
1 
精華
0 
積分
12 
點名
0  
作業系統
WIN8 
軟體版本
OFFICE2016 
閱讀權限
10 
性別
男 
註冊時間
2015-12-9 
最後登錄
2016-7-29 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2015-12-9 15:19 | 只看該作者

上網查音標英英解釋

剛剛爬了一下文
用錯的程式碼出現了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
收藏 分享

nichchen

帖子
1 
主題
0 
精華
0 
積分
1 
點名
0  
作業系統
Windows 7 
軟體版本
Office 2010 
閱讀權限
10 
性別
男 
註冊時間
2016-3-22 
最後登錄
2016-3-30 
13#
發表於 2016-3-22 16:31 | 只看該作者
我用上面的程式碼,上周大部份都可成功,但從上周六開始出現錯誤訊息,Run-time error '1004",請問高手,有好方法嗎? 下面二個平台版本,出現的狀況都一樣

Windows 7+office 2010
Windows 10+office 2010

TOP

brianhau

帖子
6 
主題
1 
精華
0 
積分
12 
點名
0  
作業系統
WIN8 
軟體版本
OFFICE2016 
閱讀權限
10 
性別
男 
註冊時間
2015-12-9 
最後登錄
2016-7-29 
12#
發表於 2016-1-11 17:47 | 只看該作者
回復 11# c_c_lai


    感謝！真的非常感謝你！
成功了！
我想您說的很清楚，但我看不大懂，需要好好消化一番！

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
11#
發表於 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
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
10#
發表於 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) 即可。

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
9#
發表於 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』。

TOP

brianhau

帖子
6 
主題
1 
精華
0 
積分
12 
點名
0  
作業系統
WIN8 
軟體版本
OFFICE2016 
閱讀權限
10 
性別
男 
註冊時間
2015-12-9 
最後登錄
2016-7-29 
8#
發表於 2015-12-28 11:47 | 只看該作者
回復 6# c_c_lai
謝謝c_c_lai，非常感激！
我試著貼上程式碼，發現完全不會動作，是欠缺什麼步驟嗎？
再次謝謝您！
dict Eng.rar (12.03 KB)

TOP

brianhau

帖子
6 
主題
1 
精華
0 
積分
12 
點名
0  
作業系統
WIN8 
軟體版本
OFFICE2016 
閱讀權限
10 
性別
男 
註冊時間
2015-12-9 
最後登錄
2016-7-29 
7#
發表於 2015-12-28 11:44 | 只看該作者
回復 4# stillfish00
謝謝stillfish00的回覆
但我還試試不出來...

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
6#
發表於 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
複製代碼
如此結果應該是你構想的方式了。

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
5#
發表於 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
複製代碼

TOP

        靜思自在 : 修行要繫緣修心，藉事練心，隨處養心。
12
返回列表 上一主題