jimjim

我也是一樣的問題 卡在send,請問如何處理

c_c_lai

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

1. Option Explicit
   
2. 
   
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
    
29. 
    
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

複製代碼