返回列表 上一主題 發帖

[發問] 抓取多網頁資料

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2020-4-14 18:36 | 顯示全部帖子
回復 1# msmplay
程式碼複製在同一模組上
  1.     Option Explicit
  2.     Dim 圖片目錄 As String, 圖片數 As Double, 圖片名稱 As String
  3.     Sub Ex_抓取多網頁資料()
  4.     Dim I As Integer, ii As Integer, e As Object
  5.     Dim Search As String, IMG As Object, Span As Object, A As Object
  6.     Search = InputBox("kd-55x8000g", "請輸入要搜尋的字串")
  7.     If Search = "" Then MsgBox "沒有請輸入......": End
  8.     With CreateObject("InternetExplorer.Application")
  9.        ' .Visible = True
  10.         .Navigate "https://www.findprice.com.tw/"
  11.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  12.         .Document.GETELEMENTBYID("search").Value = Search  '**輸入要搜尋的字串
  13.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  14.         .Document.GETELEMENTBYID("tsbb").Click                           '**搜尋鍵
  15.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  16.         Set A = .Document.form1.ALL.TAGS("tbody")
  17.         If InStr(A(1).INNERTEXT, Search) = 0 Then                              '**沒有搜尋到
  18.             MsgBox vbLf & A(1).INNERTEXT
  19.                 GoTo Xquit
  20.         Else
  21.             工作表整理
  22.             Cells(1) = Trim(Split(A(1).INNERTEXT, ">")(0))
  23.             Cells(1, 2) = "價格"
  24.             Cells(1, 3) = "說明"
  25.         End If
  26.         I = 1
  27. NE:
  28.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  29.         Set e = .Document.GETELEMENTBYID("tbContent").ALL.TAGS("TR")
  30.         For ii = 1 To e.Length - 1
  31.             With e(ii).ALL
  32.                 Set A = .TAGS("A")(0)
  33.                 If Not A Is Nothing Then
  34.                     Set IMG = A.ALL.TAGS("IMG")(0)
  35.                     Set Span = .TAGS("SPAN")
  36.                     If Not IMG Is Nothing And Span.Length > 0 Then
  37.                         If Span(0).CLASSNAME = "rec-price-20" Then
  38.                             I = I + 1
  39.                             Cells(I, "b") = Trim(Span(0).INNERTEXT)
  40.                             Cells(I, "C") = Trim(IMG.Title)
  41.                             網路圖片 IMG.Href
  42.                             Ex_網頁資料 Cells(I, "a"), A.Href
  43.                         End If
  44.                     End If
  45.                 End If
  46.             End With
  47.         Next
  48.         '**下一頁   '<a id="pg-next" href="/g/kd-55x8000g/?i=3">下一頁 &gt;</a>
  49.         For Each e In .Document.ALL.TAGS("A")
  50.             If e.ID = "pg-next" Then
  51.                 e.Click              '下一頁 (按鍵)
  52.                 GoTo NE         '循環到下一頁
  53.             End If
  54.         Next
  55. Xquit:
  56.         .Quit        '關閉網頁
  57.     End With
  58.     Range("b:b").Columns.AutoFit
  59. End Sub
  60. Private Sub 工作表整理()
  61.         圖片目錄 = ThisWorkbook.Path & "\商品圖片\"
  62.         If Dir(圖片目錄, vbDirectory) = "" Then MkDir 圖片目錄   '**沒有圖片目錄則建立之
  63.         If Dir(圖片目錄 & "*.*") <> "" Then Kill 圖片目錄 & "\*.*"  '**圖片目錄下有檔案則刪除之
  64.         圖片數 = 0
  65.        Pictures.Delete                                                                              '**刪除工作表上的圖片
  66.         With Cells
  67.             .Clear
  68.             .Columns.AutoFit
  69.             .Rows.AutoFit
  70.              .WrapText = False
  71.             .HorizontalAlignment = xlCenter
  72.             .VerticalAlignment = xlCenter
  73.         End With
  74.         With Range("c:c")
  75.             .ColumnWidth = 40
  76.             .WrapText = True
  77.         End With
  78. End Sub
  79. Private Sub Ex_網頁資料(Rng As Range, Href As String)
  80.         With Rng
  81.             .ColumnWidth = 15
  82.             .RowHeight = 90
  83.         End With
  84.         With Pictures.Insert(圖片名稱)                               '**插入圖片
  85.             .ShapeRange.LockAspectRatio = msoFalse   '**不鎖定圖片的長寬比例
  86.             .top = Rng.top
  87.             .left = Rng.left
  88.             .Height = Rng.Height
  89.             .width = Rng.width
  90.             ActiveSheet.Hyperlinks.Add Anchor:=.ShapeRange.Item(1), Address:=Href            '***超連結
  91.     End With
  92. End Sub
  93. Private Sub 網路圖片(URL As String)
  94.     Dim Xml As Object               '用來取得網頁資料
  95.     Dim Stream  As Object        'As ADODB.stream   '用來儲存二進位檔案
  96.     On Error GoTo Url_err         '處理圖片網頁的錯誤
  97. Again:
  98.     Set Xml = CreateObject("Microsoft.XMLHTTP")
  99.     Set Stream = CreateObject("ADODB.stream")
  100.     Xml.Open "GET", URL, 0
  101.     Xml.send
  102.     With Stream
  103.         .Open
  104.         .Type = 1
  105.         .write Xml.ResponseBody
  106.        ' If Dir(商品圖片) <> "" Then Kill 商品圖片
  107.        圖片名稱 = 圖片目錄 & 圖片數 & ".jpg"
  108.        圖片數 = 圖片數 + 1
  109.         .SaveToFile (圖片名稱)
  110.         .Close
  111.     End With
  112.     Set Xml = Nothing
  113.     Set Stream = Nothing
  114.     Exit Sub
  115. Url_err:
  116.     URL = "https://th.bing.com/th/id/OIP.lmGYd5XOfu-zuoG1GZW-HAHaE8?w=256&h=171&c=7&o=5&dpr=1.2&pid=1.7"
  117.     GoTo Again
  118. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 我們最大的敵人不是別人．可能是自己。
返回列表 上一主題