麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 請教網頁捉取的問題？ CreateObject("msxml2.xmlhttp") 的問題? [打印本頁]

作者: wufonna 時間: 2022-1-4 17:14 標題: 請教網頁捉取的問題？ CreateObject("msxml2.xmlhttp") 的問題?

請教網頁捉取的問題？ CreateObject("msxml2.xmlhttp") 的問題?

Sub test() '取損益表(年表)網頁
Dim Url, HTMLsourcecode, GetXml, TableG, i, j
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
Url = "http://kgieworld.moneydj.com/z/zc/zcq/zcqa/zcqa_2330.djhtm"
With GetXml
.Open "GET", Url, False
.send
' Debug.Print .document.all(0).getElementsByTagName("div")(0).outerHTML
' Debug.Print .document.all(0).getElementsByClassName("t11")(0).outerHTML
' Debug.Print .document.all(0).getElementsByClassName("table-row")(11).outerHTML
' Debug.Print .document.all(0).getElementsByClassName("t4t1 table-cell")(2).outerHTML
'Debug.Print .document.all(0).getElementsByClassName("t3n1 table-cell")(0).outerHTML
'Debug.Print .document.all(0).getElementsByClassName("t3n1 table-cell")(482).outerHTML
Debug.Print .document.all(0).getElementsByClassName("t3n1 table-cell")(482).innerHTML
Debug.Print "test"
End With
Set HTMLsourcecode = Nothing '釋放記憶體
Set GetXml = Nothing
End Sub '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

複製代碼

請教大大，網頁改版，試修改程式，Debug.Print .document.all(0).getElementsByClassName("t3n1 table-cell")(482).innerHTML
用CreateObject("InternetExplorer.Application")可執行，用CreateObject("msxml2.xmlhttp") 會錯誤，請問如何修改，謝謝[attach]34566[/attach]

作者: wufonna 時間: 2022-1-4 20:52

我試著一個方法捉表格有更好的方法麻煩大大告知
Sub Test() '取損益表(年表)網頁
Dim Url, HTMLsourcecode, GetXml, TableG, i, j
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
Url = "http://kgieworld.moneydj.com/z/zc/zcq/zcqa/zcqa_2330.djhtm"
With GetXml
.Open "GET", Url, False
.Send

HTMLsourcecode.body.innerhtml = .Responsetext

' Debug.Print HTMLsourcecode.all.tags("div")(12).innertext
' Debug.Print HTMLsourcecode.all.tags("div")(15).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(15).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(400).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(482).innertext

'For i = 5 To 10
' Debug.Print HTMLsourcecode.all.tags("div")(i).innertext
' Next i

For j = 0 To 300
Debug.Print HTMLsourcecode.all.tags("span")(j).innertext
Next j
'
' Debug.Print HTMLsourcecode.all.tags("div")(5).innertext
' Debug.Print HTMLsourcecode.all.tags("div")(6).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(0).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(1).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(2).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(3).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(4).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(5).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(6).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(7).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(8).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(9).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(10).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(11).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(12).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(13).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(14).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(15).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(16).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(17).innertext
' Debug.Print HTMLsourcecode.all.tags("span")(18).innertext

End With
Set HTMLsourcecode = Nothing '釋放記憶體
Set GetXml = Nothing
End Sub '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

作者: quickfixer 時間: 2022-1-4 23:09

回復 2# wufonna

http://forum.twbts.com/viewthrea ... p;extra=&page=2

01 ===>>> #1173

作者: wufonna 時間: 2022-1-4 23:33

回復 3# quickfixer

謝謝大大
就是這程式，最近網頁又改版了，捉不到損益表的質料，之前是 table,現在改為div內，無法捉表格。

作者: quickfixer 時間: 2022-1-4 23:52

回復 4# wufonna

那個#1173,我只改網址,套用ok喔

[attach]34569[/attach]

作者: wufonna 時間: 2022-1-4 23:59

回復 3# quickfixer
請大大可以貼上程式嗎？
我𧥾不到 01 ===>>> #1173
謝謝

作者: wufonna 時間: 2022-1-5 00:03

Private Sub GetIncome(ByVal ss As String) '取損益表(年表)網頁
Dim Url, HTMLsourcecode, GetXml, TableG, i, j
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
Url = "http://kgieworld.moneydj.com/z/zc/zcq/zcqa/zcqa_" & ss & ".djhtm"
With GetXml
.Open "GET", Url, False
.Send
HTMLsourcecode.body.innerhtml = .Responsetext
Set TableG = HTMLsourcecode.all.tags("table")(2).Rows
For i = 0 To TableG.Length - 1
For j = 0 To TableG(i).Cells.Length - 1
工作表4.Cells(i + 1, j + 1) = TableG(i).Cells(j).innertext
Next j
Next i
End With
Set HTMLsourcecode = Nothing '釋放記憶體
Set GetXml = Nothing
End Sub '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

複製代碼

之前的捉不到

作者: quickfixer 時間: 2022-1-5 00:15

回復 7# wufonna

f3202大大,在 2019-6-18 07:55 #11 給你的01網址
去網址裡面的2021-12-24 18:11 #1173 的文章copy:@

作者: wufonna 時間: 2022-1-5 00:36

回復 8# quickfixer

找到了謝謝大大我在試看看

作者: wufonna 時間: 2022-1-5 01:16

回復 1# wufonna
謝謝大大改好了

作者: wufonna 時間: 2022-1-6 19:01

本帖最後由 wufonna 於 2022-1-6 19:04 編輯

回復 1# wufonna

金融保險業別的表格格式不一樣抓不到正確的資料
我是取
ROE=損益表-稅前淨利(67)/資產負債表股-東權益總額(95)
.Cells(i, 9).Value = 工作表4.Cells(67, 2).Value / 工作表5.Cells(95, 2).Value 'ROE%
求改正方法謝謝

附檔是抓到的資料

作者: wufonna 時間: 2022-1-10 19:43

回復 1# wufonna

Sub test()
Debug.Print "test"
With Sheet1
Debug.Print .Columns("A").Find("稅前淨利").Row
Debug.Print .Range("b" & Sheet1.Columns("A").Find("稅前淨利").Row).Value
Debug.Print .Rows("67").Find(-336).Column
Debug.Print .Rows("67").Find("-336").Column
Debug.Print .Rows("67").Find("52").Column
Debug.Print .Rows("67").Find(0).Column '找到101內的0
End With
End Sub

複製代碼

紀錄一下

作者: wufonna 時間: 2022-1-11 02:19

' .Cells(i, 9).Value = 工作表4.Cells(67, 2).Value / 工作表5.Cells(95, 2).Value 'ROE%
.Cells(i, 9).Value = 工作表4.Range("b" & 工作表4.Columns("A").Find("稅前淨利").Row).Value / 工作表5.Range("b" & 工作表5.Columns("A").Find("股東權益總額").Row).Value 'ROE% 不固定位子

複製代碼

回復 1# wufonna

修該片段

作者: GBKEE 時間: 2022-1-11 15:43

本帖最後由 GBKEE 於 2022-1-11 17:12 編輯

回復 7# wufonna
要了解網頁編碼,才能得心應手

Private Sub GetIncome() '取損益表(年表)網頁
Dim Url, HTMLsourcecode, GetXml, TableG, i, j
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
Url = "http://kgieworld.moneydj.com/z/zc/zcq/zcqa/zcqa_2330.djhtm"
With GetXml
.Open "GET", Url, False
.Send
HTMLsourcecode.body.innerhtml = .Responsetext
Set TableG = HTMLsourcecode.getelementsbyclassname("table-row")
'***網頁的編碼**********************************
'<div class="table-row"> 為所要的資料的網頁元素
'期別
'2020
'2019
'2018
'2017
'2016
'2015
'2014
'2013
'</div>************************************
For i = 0 To TableG.Length - 1
For j = 0 To TableG(i).all.tags("span").Length - 1
Cells(i + 1, j + 1) = TableG(i).all.tags("span")(j).innertext
Next j
Next i
End With
Set HTMLsourcecode = Nothing '釋放記憶體
Set GetXml = Nothing
End Sub '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

複製代碼

ROE=損益表-稅前淨利(67)/資產負債表股-東權益總額(95)
.Cells(i, 9).Value = 工作表4.Cells(67, 2).Value / 工作表5.Cells(95, 2).Value 'ROE%
#11 的問題這公式應可解決

作者: GBKEE 時間: 2022-1-11 15:51

本帖最後由 GBKEE 於 2022-1-11 15:54 編輯

回復 11# wufonna
Pchome 的線型走勢網頁 VBA 參考看看

Option Explicit
Dim Rng As Range, 資訊_Msg As Boolean, ie As New InternetExplorer
Sub AllFile() '重新更新所有資料
Dim i As Integer
With Sheets("股票")
.UsedRange.CurrentRegion.Offset(0, 1).Clear
資訊_Msg = True
For i = 1 To .Range("A" & .Rows.Count).End(xlUp).Row
程式執行 Cells(i, 1)
Next
資訊_Msg = False
If 資訊_Msg = False Then ie.Quit
End With
End Sub
Sub ex()
程式執行 [B1]
End Sub
Private Sub 程式執行(xRng As Range) '單筆更新指定A欄的資料
If xRng.Column > 1 Then MsgBox xRng & " 不在 A欄": Exit Sub
' If ie Is Nothing Then Set ie = New InternetExplorer
Set Rng = xRng
股票資訊
Rng.Select
If 資訊_Msg = False Then ie.Quit
End Sub
Sub 股票資訊()
Dim E As Object, Ar(), A As Integer, R As Integer, C As Integer
With Rng
A = .Parent.UsedRange.Columns.Count - 1
If 資訊_Msg = False Then
.Offset(, 1).Resize(, A).Select
.Offset(, 1).Resize(, A).Clear
End If
If .Row = 1 Then .Cells(1, 2) = "股票名稱 ": .Cells(1, 3) = "股票價格 "
End With
On Error GoTo Beerr
Be:
With ie
DoEvents
.Navigate "https://pchome.megatime.com.tw/stock/sid" & Rng & ".html" '
' .Visible = True
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Do: DoEvents
If InStr(.Document.body.innertext, "查無") Then '查無股票代號
Rng.Offset(, 1) = "查無 " & Rng: Exit Sub
ie.Quit
End If
Loop Until Not InStr(.Document.body.innertext, "查無")
If Rng.Row > 1 Then
Do: DoEvents
Set E = .Document.querySelector("em[class='corp-name']") '指定這元素 讀取 (股票名稱, 代號)
'台　泥  (1101)
Loop Until TypeName(E) = "HTMLPhraseElement"
If Trim(E.ALL.TAGS("SPAN")(0).innertext) <> "(" & Rng & ")" Then
Rng.Offset(, 1) = "查無 " & Rng: Exit Sub
Else
Rng.Cells(, 2) = Trim(Split(E.innertext, "(")(0)) 'Split 函數傳回一個陳列索引從零開始的一維陣列 , 它包含指定數目的子字串
End If
Set E = .Document.getelementbyid("stock_info_data_a").ALL.TAGS("SPAN")(0) '股票價格 id="stock_info_data_a"
'<div class="price s-down fadein_black" id="stock_info_data_a">
'18.95 **TAGS("SPAN")(0) 's-down 股價下降
'▼-0.10 **TAGS("SPAN")(1)
'-0.52% **TAGS("SPAN")(2)
'18.79億</div> **TAGS("SPAN")(3)
Rng.Cells(, 3) = E.innertext
End If
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Do: DoEvents
Set E = .Document.ALL.TAGS("table")(1)
Loop Until TypeName(E) = "HTMLTable"
If Rng.Row > 1 Then Ar = Array(3, 5, 7, 9) Else Ar = Array(2, 4, 6, 8)
'Rng.Row > 1 >>從第2列開始下載資料
'Array(2, 4, 6, 8) 為標題的Row **Ar = Array(3, 5, 7, 9 )為資料的Row
A = 4 '設定資料欄位的起始欄位,前有 1股票代碼欄,2股票名稱欄,3股票價格欄
For R = 0 To UBound(Ar) - 1
For C = 0 To E.Rows(Ar(R)).Cells.Length - 1
Rng.Cells(, A) = E.Rows(Ar(R)).Cells(C).innertext
A = A + 1 '資料欄位+1
Next
Next
End With
Exit Sub
Beerr:
Set ie = New InternetExplorer
GoTo Be
End Sub

複製代碼

作者: wufonna 時間: 2022-1-11 19:35

回復 14# GBKEE

謝謝版主從中學到很多。

作者: wufonna 時間: 2022-1-11 19:47

回復 15# GBKEE

謝謝娰主程式，學習中。

作者: wufonna 時間: 2022-1-11 20:12

回復 14# GBKEE

Sub GetIncome() '取損益表(年表)網頁
Dim Url, HTMLsourcecode, GetXml, TableG, i, j
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
Url = "http://kgieworld.moneydj.com/z/zc/zcq/zcqa/zcqa_2330.djhtm"
With GetXml
.Open "GET", Url, False
.Send
HTMLsourcecode.body.innerhtml = .Responsetext
Set TableG = HTMLsourcecode.getelementsbyclassname("table-row")
'***網頁的編碼**********************************
'<div class="table-row"> 為所要的資料的網頁元素
'期別
'2020
'2019
'2018
'2017
'2016
'2015
'2014
'2013
'</div>************************************
For i = 0 To TableG.Length - 1
For j = 0 To TableG(i).all.tags("span").Length - 1
Cells(i + 1, j + 1) = TableG(i).all.tags("span")(j).innertext
Next j
Next i
End With
Set HTMLsourcecode = Nothing '釋放記憶體
Set GetXml = Nothing
End Sub '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

複製代碼

請教版大我 office 2007 版測試程式
Set TableG = HTMLsourcecode.getelementsbyclassname("table-row")
這行會誤，是否版本的問題
謝謝版大

作者: wufonna 時間: 2022-1-11 20:38

回復 14# GBKEE

這次網頁改版，抓取的有的股票行數不同，像金融股那一段取B67欄就不在那行，就嘗試用find ,全部上市可以跑完。

作者: GBKEE 時間: 2022-1-12 09:58

本帖最後由 GBKEE 於 2022-1-12 10:00 編輯

回復 18# wufonna
多寫幾行試試試試看

Private Sub GetIncome() '取損益表(年表)網頁
Dim Url, HTMLsourcecode, GetXml, TableG As Object, i As Integer, j As Integer, a As Integer
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
Url = "http://kgieworld.moneydj.com/z/zc/zcq/zcqa/zcqa_2330.djhtm"
With GetXml
.Open "GET", Url, False
.send
HTMLsourcecode.write .Responsetext
Do ' 程式運行速度快用迴圈,確保TableG物件下載完整
Set TableG = HTMLsourcecode.all.tags("div")
DoEvents
'** "JScriptTypeInfo" 可在區域變數視窗查看
'** 或是 Debug.Print TypeName(TableG) 得知
Loop Until TypeName(TableG) = "JScriptTypeInfo"
'*****得知 classname="table-row" 的位置
For a = 0 To TableG.Length - 1
'Debug.Print a, TableG(a).classname
If TableG(a).classname = "table-row" Then Exit For '讀取資料起始列數
Next
'***************************************
With ActiveSheet
.Cells.Clear
For i = a To TableG.Length - 1
For j = 0 To TableG(i).all.tags("span").Length - 1
.Cells(i - (a - 1), j + 1) = TableG(i).all.tags("span")(j).innertext
'****** i - ( a-1) >>修正從第一列開始下載資料
Next j
Next i
End With
'***網頁的編碼**********************************
'<div class="table-row"> 為所要的資料的網頁元素
'期別
'2020
'2019
'2018
'2017
'2016
'2015
'2014
'2013
'</div>************************************
End With
Set HTMLsourcecode = Nothing '釋放記憶體
Set GetXml = Nothing
End Sub '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

複製代碼

作者: wufonna 時間: 2022-1-12 11:54

回復 20# GBKEE

謝謝版主，我執行程式沒停止，用 debug 測試，在這段裡迴圈

Do ' 程式運行速度快用迴圈,確保TableG物件下載完整
Set TableG = HTMLsourcecode.all.tags("div")
DoEvents
'** "JScriptTypeInfo" 可在區域變數視窗查看
'** 或是 Debug.Print TypeName(TableG) 得知
N = N + 1
Debug.Print TypeName(TableG) & N
Loop Until TypeName(TableG) = "JScriptTypeInfo"

複製代碼

作者: GBKEE 時間: 2022-1-12 13:47

本帖最後由 GBKEE 於 2022-1-12 13:53 編輯

回復 21# wufonna

[attach]34592[/attach]
上圖你PC環境中 TypeName(TableG)
下圖我PC環境中程式碼TypeName(TableG) 不一樣
這裡要修改一下

[[attach]34595[/attach]

作者: wufonna 時間: 2022-1-12 15:46

回復 22# GBKEE

謝謝版大
F8 執行

[attach]34596[/attach]物件名稱不一樣
Object/DispHTMLElementCollection

作者: wufonna 時間: 2022-1-12 16:23

回復 22# GBKEE

謝謝版大改過就可以了，從中學習很多

Do ' 程式運行速度快用迴圈,確保TableG物件下載完整
Set TableG = HTMLsourcecode.all.tags("div")
DoEvents
N = N + 1
'** "JScriptTypeInfo" 可在區域變數視窗查看
Debug.Print TypeName(TableG) & N
'** 或是 Debug.Print TypeName(TableG) 得知
' Loop Until TypeName(TableG) = "JScriptTypeInfo"
Loop Until TypeName(TableG) = "DispHTMLElementCollection"

複製代碼

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