VBA Javascript 彈出窗口
[英]VBA Javascript Pop-Up Window
問題描述
我正在嘗試從網站獲取一些數據，但需要解析的 HTML 對我的水平和知識來說相當復雜，但是，該網站有一個很好的功能，他會將數據排列在表格中。 問題是該表的創建類似於<a class="LinkColor" href="javascript:TableFormat()">Table Format</a>彈出一個新的 chrome 窗口。 我在 Chrome 的開發者工具中嘗試了事件監聽器，但沒有成功。 有沒有辦法得到那張桌子？
到目前為止，我有以下代碼：
Option Explicit
Public Sub IndianMoU()
Dim strPost As String, d As String, s As String, startDate As String, endDate As String
Dim http As Object
startDate = "01.08.2019" 'Replace(UserForm1.TextBox1, "/", ".")
endDate = "31.08.2019" '"Replace(UserForm1.TextBox2, "/", ".")
Const Boundary As String = "----WebKitFormBoundary11XcIMf4gNidMvY2"
Set http = CreateObject("MSXML2.XMLHTTP")
'Get authentication ticket:
'Build source form for login
d = "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""flag1""" & vbCrLf & vbCrLf
d = d & "0"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""HidFlag""" & vbCrLf & vbCrLf
d = d & "Agreed"
d = d & vbCrLf & "--" & Boundary & "--" & vbCrLf
With http
.Open "POST", "http://www.iomou.org/php/InspData.php", False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=----WebKitFormBoundary11XcIMf4gNidMvY2"
.send d
's = .responseText
End With
'Build source form for inpsections
d = "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""FindInspAction""" & vbCrLf & vbCrLf
d = d & "Find"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""StartOffset""" & vbCrLf & vbCrLf
d = d & "1"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""flag1""" & vbCrLf & vbCrLf
d = d & "0"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""txtStartDate""" & vbCrLf & vbCrLf
d = d & startDate
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""txtEndDate""" & vbCrLf & vbCrLf
d = d & endDate
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""opt_txtISC""" & vbCrLf & vbCrLf
d = d & "I"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""txtISC""" & vbCrLf & vbCrLf
d = d & ""
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""opt_lstFCS""" & vbCrLf & vbCrLf
d = d & "F"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""lstFCS""" & vbCrLf & vbCrLf
d = d & "PT"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""chkDet""" & vbCrLf & vbCrLf
d = d & "All"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""InspType""" & vbCrLf & vbCrLf
d = d & "All"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""lstAuth""" & vbCrLf & vbCrLf
d = d & "000"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""SortOrder""" & vbCrLf & vbCrLf
d = d & "NoSort"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""AscDsc""" & vbCrLf & vbCrLf
d = d & "Desc"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""lstLimit""" & vbCrLf & vbCrLf
d = d & "600"
d = d & vbCrLf & "--" & Boundary & "--" & vbCrLf
With http
.Open "POST", "http://www.iomou.org/php/InspData.php", False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=----WebKitFormBoundary11XcIMf4gNidMvY2"
.send d
s = .responseText
End With
Debug.Print s
End Sub
先感謝您。
愛德華多
2 個解決方案
解決方案1
1 已采納 2019-12-13 23:38:44
正如您所發現的（我建議您作為答案發布），您可以通過multipart/form-data模擬頁面在初始 POST xhr 更新方面的作用，該數據在后端運行 SQL 查詢以生成所需的結果。 然后，您將后續的 GET xhr 發送到 tableFormat php URI。 這是高效的，因為 IOMOU 數據庫是在后台查詢的，您可以從最新的檢查制度中獲得額外的信息，例如SRP的矩陣計算輸出以及關於給定缺陷是否是滯留原因的決定。
備用：
有趣的是，您可以只發送兩個 GET，其中第一個是仍然啟動后端數據准備的查詢字符串； 使用 serverXMLHTTP 然后我可以發出第二個 GET 並獲取結果。
示例輸出行
VBA
Option Explicit
Public Sub GetInspectionResults()
Dim html As MSHTML.HTMLDocument, clipboard As Object
Set html = New MSHTML.HTMLDocument:
Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "GET", "http://www.iomou.org/php/InspData.php?lstLimit=1000&StartOffset=1&FindInspAction=Find&txtStartDate=04.12.2018&txtEndDate=12.12.2019&opt_txtISC=I&txtISC=&opt_lstFCS=F&lstFCS=PT&lstAuth=000&chkDet=All&InspType=All&SortOrder=NoSort&AscDsc=Desc", False
.send
.Open "GET", "http://www.iomou.org/php/TableFormat.php", False
.send
html.body.innerHTML = .responseText
End With
clipboard.SetText html.querySelector("#tblDiaplayResult").outerHTML
clipboard.PutInClipboard
ThisWorkbook.Worksheets("Test").Range("A1").PasteSpecial
End Sub
丑陋的方式：
如果您有興趣使用查詢字符串 url 構造，而不調用 php uri，則另一種方法如下所示。 它不是特別健壯（例如長鏈方法），所以我只會回顧它以深入了解 DOM 遍歷的可用方法，以及如何將結果調整為指定格式，即您在頁面上看到的輸出表要求表格格式。
我在代碼中做了注釋，但總的來說我是：
- 更改查詢字符串
limit參數以一次獲取 1000 個結果以減少請求數。 你可能會比這更高。 我使用 set startDate、endDate 和 flag 參數。 還有其他你可以設置。 我使用一些默認值。 根據缺陷鏈接的數量，您可以有 1 到n + 1請求，其中n是結果數。 將其與您的兩個請求進行比較。 - 發出初始請求並確定結果總數。 如果可用結果多於 1000，則以 1000 個為一批發出更多請求。
- 對於每個請求，我最初都會獲取兩個節點列表。 一，
detentionReleaseDates，是一個節點列表，分別包含奇數和偶數索引處的所有拘留/釋放日期信息。 另一個loopNodes包含各個檢查表中的其他節點。 在后者中，項目在第 17 步重復，例如船名每第 17 個節點重復一次。 一點數學知識讓我可以使用一個循環同時訪問這兩個 nodeList 並使用此信息填充一個數組resultSet。 - 我使用兩個數組
inputPositions和outputPositions來處理loopNodes中的索引到輸出中的列的映射。 輸出中有 24 列。 其中 16 列是從loopNodes.length的 17 寬循環中的節點填充的。 由於此方法無法獲得信息，一些索引留空。detentionDate/releaseDate信息來自另一個 nodeList，其中應用了一些規則來確定最終輸出。Sr. No.是行（檢查）的自動編號。 要獲取缺陷信息，將提取關聯的 url（如果適用），並向該 url 發出新請求以獲取兩個表格，這兩個表格提供Rectified Deficiencies Of No. of Deficiencies和Deficiency Code and Name字段值的糾正缺陷數量。 - 在循環期間，我使用輔助函數
GetLastRow來查找頁面上最后占用的行，這樣我就可以將當前resultSet數組寫入下一個可用行。
由於映射可視化的寬度，我包含了從給定輸入生成正確輸出的過程的 gif：
給你檢查的時間有點慢。
VBA：
Option Explicit
'MaxRequests <= n+1
Public Sub GetShipInspectionResults()
Const LIMIT As Long = 1000
Const FLAG As String = "PT"
Dim startDate As String, endDate As String, xhr As Object
Dim ws As Worksheet, re As Object, html As MSHTML.HTMLDocument
startDate = "04.12.2018"
endDate = "12.12.2019"
Set xhr = CreateObject("MSXML2.XMLHTTP")
Set html = New MSHTML.HTMLDocument
Set re = CreateObject("VBScript.RegExp")
Set ws = ThisWorkbook.Worksheets("Results")
ClearSheet ws
Dim url As String, numberOfResults As Long, numberOfPages As Long, page As Long
url = GetUrl(startDate, endDate, LIMIT, FLAG, 1)
UpdatePage html, xhr, url
numberOfResults = GetCount(re, html.querySelector(".generalinformation b").innerText, "Total\s+(\d+)\s+records")(0)
numberOfPages = Application.RoundUp(numberOfResults / LIMIT, 0)
Dim totalRows As Long, headers()
headers = GetHeaders
ws.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
For page = 1 To numberOfPages
If page > 1 Then
url = GetUrl(startDate, endDate, LIMIT, FLAG, page)
UpdatePage html, xhr, url
End If
totalRows = GetNumberOfTableRows(re, html)
Dim resultSet(), valuesForTable()
ReDim resultSet(1 To totalRows, 1 To UBound(headers) + 1)
valuesForTable = GetResults(html, resultSet, xhr)
With ws
.Cells(IIf(page = 1, 2, GetLastRow(ws) + 1), 1).Resize(UBound(valuesForTable, 1), UBound(valuesForTable, 2)) = valuesForTable
End With
Next
End Sub
Public Function GetResults(ByVal html As MSHTML.HTMLDocument, ByRef resultSet(), ByVal xhr As Object) As Variant
'Populate an array with current page results. There are two nodeLists used. 1 for detention release dates and 1 for _
pretty much all the other nodeLists. loopNodes has most of the info with items e.g.ship name appearing at step 17. _
detentionReleaseDates is shorter but has its length has the same common divisor of 17 so a little maths means only one _
loop required to populate array from both lists.
' "Sr. No.", "IMO Number", "Call Sign", "Gross Tonnage", _
' "Deadweight", "IMO Company No.", "Particulars of Company", _
' "Ship Name", "Flag", "Date Keel Laid", "Ship Type", "Classification Society", _
' "Place of Inspection", "Date of Inspection", "Type of Inspection", _
' "Detained", "Date of Detention", "Date of Release", "Deficiencies", _
' "No. of Rectified Deficiencies Of No. of Deficiencies", "Deficiency Code and Name", _
' "Detainable Deficiency", "Inspecting Authority", "SRP Value"
'"Sr. No." Auto-numbered
Dim detentionReleaseDates As Object, loopNodes As Object, html2 As MSHTML.HTMLDocument
Set html2 = New MSHTML.HTMLDocument
Set detentionReleaseDates = html.querySelectorAll("[border='1'] tr + tr td") 'loop step 2. Position odd detention, even release
Set loopNodes = html.querySelectorAll("td font > strong")
Dim inputPositions(), outputPositions(), i As Long, j As Long
inputPositions = Array(0, 1, 2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16) 'map position in nodeList (step block of 17) to desired output column.
outputPositions = Array(8, 2, 3, 4, 5, 9, 10, 11, 12, 13, 14, 15, 6, 7, 16, 23)
Dim requestUrls(), k As Long, r As Long, releaseDate As String, detentionDate As String
requestUrls() = GetDeficiencyLinks(html)
For i = 0 To loopNodes.Length - 1 Step 17 '0,17,34,51,68,.....1598,1615
DoEvents
r = r + 1
resultSet(r, 1) = i / 17 + 1
detentionDate = detentionReleaseDates.Item(2 * i / 34).innerText
releaseDate = detentionReleaseDates.Item(2 * i / 34 + 1).innerText
If releaseDate = "00.00.0000" Then releaseDate = "Under Detention" 'Apply handling ruled. WIP.
resultSet(r, 17) = IIf(detentionDate = vbNullString And releaseDate = vbNullString, "Not Applicable", detentionDate)
resultSet(r, 18) = IIf(detentionDate = vbNullString And releaseDate = vbNullString, "Not Applicable", releaseDate)
For j = LBound(inputPositions) To UBound(inputPositions) ' use IO column mappings to determine where current node innerText goes
k = inputPositions(j)
resultSet(r, outputPositions(j)) = IIf(j = 0, loopNodes.Item(i).LastChild.innerText, loopNodes.Item(i + k).innerText)
Next
Dim url As String, tables As Object, m As Long
url = requestUrls(i / 17 + 1)
'handle according to whether "No deficiencies". Where additional request made then need loop with row increment to add deficiency rows.
If url <> "No Deficiencies" Then
UpdatePage html2, xhr, url 'make request for deficiencies tables to populate output columns 20-21
Set tables = html2.querySelectorAll("#tbldisplay")
resultSet(r, 20) = tables.Item(0).Rows(1).Children(1).innerText & " Of " & tables.Item(0).Rows(1).FirstChild.innerText
For m = 1 To tables.Item(1).Rows.Length - 2 ' add in rows per deficiency
resultSet(r, 21) = tables.Item(1).Rows(m).Children(1).innerText & ":" & tables.Item(1).Rows(m).Children(2).innerText
r = r + 1
Next
Set tables = Nothing
Else
resultSet(r, 20) = "0 Of 0"
End If
Next
GetResults = resultSet
End Function
Public Function GetDeficiencyLinks(ByVal html As MSHTML.HTMLDocument) As Variant
Dim results(), nodes As Object, i As Long, url As String
Set nodes = html.querySelectorAll("[bgcolor='#FFDBE7']") 'choose a node that also account for No deficiencies
ReDim results(1 To nodes.Length)
For i = 0 To nodes.Length - 1
url = "No Deficiencies"
On Error Resume Next 'fragile walk to `a` tag to get href. This could be replaced with using a surrogate HTMLDocument variable and then html3.body.innerHTML = nodes.Item(i).outerHTML: url = html3.querySelector("a").href
url = Replace$(nodes.Item(i).LastChild.LastChild.LastChild.LastChild.FirstChild.href, "about:", "http://www.iomou.org/php/")
On Error GoTo 0
results(i + 1) = url
Next
GetDeficiencyLinks = results
End Function
Public Function GetNumberOfTableRows(ByVal re As Object, ByVal html As MSHTML.HTMLDocument) As Long
Dim totalNumber As Long, nodes As Object, i As Long
Set nodes = html.querySelectorAll("[bgcolor='#FFDBE7']")
For i = 0 To nodes.Length - 1
Dim searchString As String, matches()
searchString = nodes.Item(i).LastChild.LastChild.innerText
matches = GetCount(re, searchString, "(No Deficiencies)|(\d+)")
If UBound(matches) = 0 Then
totalNumber = totalNumber + matches(0)
Else
totalNumber = totalNumber + matches(1)
End If
Next
GetNumberOfTableRows = totalNumber
End Function
Public Function GetCount(ByVal re As Object, ByVal s As String, ByVal p As String) As Variant
Dim matches As Object, results()
'Should probably use .test wrapper and handle no matches. Below might benefit from being split out into different functions to handle different cases.
With re
.Global = True
.MultiLine = True
.Pattern = p
Set matches = .Execute(s)
ReDim results(0)
If matches.Count = 1 And InStr(s, "Rectified") > 0 Then
results(0) = matches(0)
ElseIf matches.Count = 1 And InStr(s, "No Deficiencies") > 0 Then
results(0) = 1
ElseIf matches.Count = 1 Then
results(0) = matches(0).submatches(0)
Else
ReDim results(1)
results = Array(matches(0), matches(1))
End If
End With
GetCount = results
End Function
Public Sub UpdatePage(ByVal html As MSHTML.HTMLDocument, ByVal xhr As Object, ByVal url As String)
With xhr
.Open "GET", url, False
.send
html.body.innerHTML = .responseText
End With
End Sub
Public Function GetUrl(ByVal startDate As String, ByVal endDate As String, ByVal LIMIT As Long, ByVal FLAG As String, ByVal pageNumber As Long) As String
'Params: lstFCS = Flag;txtStartDate = startDate; txtEndDate = endDate. Add other params if required
'Example: http://www.iomou.org/php/InspData.php?lstLimit=1000&StartOffset=1&FindInspAction=Find&txtStartDate=04.12.2018&txtEndDate=12.12.2019&opt_txtISC=I&txtISC=&opt_lstFCS=F&lstFCS=PT&lstAuth=000&chkDet=All&InspType=All&SortOrder=NoSort&AscDsc=Desc
Dim url As String
url = "http://www.iomou.org/php/InspData.php?lstLimit=" & LIMIT & "&StartOffset=" & pageNumber
url = url & "&FindInspAction=Find&txtStartDate=" & startDate & "&txtEndDate=" & endDate
url = url & "&opt_txtISC=I&txtISC=&opt_lstFCS=F&lstFCS=" & FLAG & "&lstAuth=000&chkDet=All&InspType=All&SortOrder=NoSort&AscDsc=Desc"
GetUrl = url
End Function
Private Function GetLastRow(ByVal ws As Worksheet) As Long
GetLastRow = ws.Cells.Find(What:="*", After:=ws.Range("A1"), _
LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
End Function
Public Function GetHeaders() As Variant
Dim headers()
headers = Array("Sr. No.", "IMO Number", "Call Sign", "Gross Tonnage", _
"Deadweight", "IMO Company No.", "Particulars of Company", _
"Ship Name", "Flag", "Date Keel Laid", "Ship Type", "Classification Society", _
"Place of Inspection", "Date of Inspection", "Type of Inspection", _
"Detained", "Date of Detention", "Date of Release", "Deficiencies", _
"No. of Rectified Deficiencies Of No. of Deficiencies", "Deficiency Code and Name", _
"Detainable Deficiency", "Inspecting Authority", "SRP Value")
GetHeaders = headers
End Function
Public Sub ClearSheet(ByVal ws As Worksheet)
With ws.Cells
.ClearContents
.ClearFormats
End With
End Sub
參考資料（VBE>工具>參考資料）：
- 微軟 HTML 對象庫
讀：
解決方案2
1 2019-12-16 09:46:52
我發現在發送“POST”請求后，一個簡單的“GET”到表的鏈接將恢復為我正在尋找的表。
Option Explicit
Public Sub WriteOutShipInspectionTableIM()
Dim http As Object, s As String, ws As Worksheet, re As Object, lrow As Long, d As String, startDate As String, endDate As String, r As Long, clipboard As MSForms.DataObject
Dim tables As MSHTML.IHTMLElementCollection, table As MSHTML.HTMLTable
Set http = CreateObject("MSXML2.XMLHTTP")
Set ws = ThisWorkbook.Worksheets("Indian MoU")
Set re = CreateObject("VBScript.RegExp")
Folha5.UsedRange.ClearContents
Dim html As HTMLDocument, body As String, headers(), results()
headers = Array("Inspec. Number", "IMO Number", "Call Sign", "Gross Tonnage", "Deadweight", "ISM Comp. IMO", "ISM Comp. Details", "Ship Name", "Flag State", "Year Built", "Ship Type", "Class Society", "Place of Inspection", "Date of Inspection", "Inspection Type", "Detained", "Date of Dentention", "Date of Realese", "Deficiencies", "Defficiencies Rectified", "Deficiency Code and Name", "Detainable", "Authority", "Ship Risk")
Set html = New MSHTML.HTMLDocument
With re
.Global = True
.MultiLine = True
End With
startDate = "01.08.2019" 'Replace(UserForm1.TextBox1, "/", ".")
endDate = "31.08.2019" 'Replace(UserForm1.TextBox2, "/", ".")
Const Boundary As String = "----WebKitFormBoundary11XcIMf4gNidMvY2"
'Build source form for login
d = "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""flag1""" & vbCrLf & vbCrLf
d = d & "0"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""HidFlag""" & vbCrLf & vbCrLf
d = d & "Agreed"
d = d & vbCrLf & "--" & Boundary & "--" & vbCrLf
With http
.Open "POST", "http://www.iomou.org/php/InspData.php", False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=----WebKitFormBoundary11XcIMf4gNidMvY2"
.send d
End With
'Build source form for inpsections
d = "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""FindInspAction""" & vbCrLf & vbCrLf
d = d & "Find"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""StartOffset""" & vbCrLf & vbCrLf
d = d & "1"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""flag1""" & vbCrLf & vbCrLf
d = d & "0"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""txtStartDate""" & vbCrLf & vbCrLf
d = d & startDate
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""txtEndDate""" & vbCrLf & vbCrLf
d = d & endDate
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""opt_txtISC""" & vbCrLf & vbCrLf
d = d & "I"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""txtISC""" & vbCrLf & vbCrLf
d = d & ""
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""opt_lstFCS""" & vbCrLf & vbCrLf
d = d & "F"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""lstFCS""" & vbCrLf & vbCrLf
d = d & "PT"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""chkDet""" & vbCrLf & vbCrLf
d = d & "All"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""InspType""" & vbCrLf & vbCrLf
d = d & "All"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""lstAuth""" & vbCrLf & vbCrLf
d = d & "000"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""SortOrder""" & vbCrLf & vbCrLf
d = d & "NoSort"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""AscDsc""" & vbCrLf & vbCrLf
d = d & "Desc"
d = d & vbCrLf & "--" & Boundary & vbCrLf
d = d & "Content-Disposition: form-data; name=""lstLimit""" & vbCrLf & vbCrLf
d = d & "600"
d = d & vbCrLf & "--" & Boundary & "--" & vbCrLf
With http
.Open "POST", "http://www.iomou.org/php/InspData.php", False
.setRequestHeader "Content-Type", "multipart/form-data; boundary=----WebKitFormBoundary11XcIMf4gNidMvY2"
.send d
s = .responseText
Dim totalInspections As Long
totalInspections = CLng(GetString(re, s, "<B>[\s\S]*? (\d+) [\s\S]*?<\/B>"))
End With
With http
.Open "GET", "http://www.iomou.org/php/TableFormat.php", False
.send
s = .responseText
html.body.innerHTML = GetString(re, s, "(<TABLE[\s\S]*?tblDiaplayResult[\s\S]*?<\/TABLE>)")
ReDim results(1 To totalInspections, 1 To UBound(headers) + 1)
results = PopulateArray(http, html, r, results)
End With
With ws
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
Dim lastro, e As Long
lastro = Folha5.Cells(Rows.Count, 1).End(xlUp).Row
For e = 2 To lastro
Folha5.Range("T" & e).Value = Right(Folha5.Range("T" & e).Value, 1)
Debug.Print Folha5.Range("T" & e).Value
Next e
End Sub
Public Function PopulateArray(ByVal http As Object, ByVal html As MSHTML.HTMLDocument, ByRef r As Long, ByRef results As Variant) As Variant
Dim c As Long, tr As MSHTML.HTMLTableRow, td As MSHTML.HTMLTableCell, i As Long, insp As String
For i = 2 To html.querySelectorAll("tr").Length - 1
r = r + 1: c = 1
For Each td In html.querySelectorAll("tr").Item(i).getElementsByTagName("td")
results(r, c) = td.innerText
c = c + 1
Next
Next
PopulateArray = results
End Function
Public Function GetString(ByVal re As Object, ByVal s As String, ByVal p As String) As String
With re
.Pattern = p
GetString = .Execute(s)(0).submatches(0)
End With
End Function
所以基本上，最后，我有一個“POST”請求登錄，另一個請求在網站后台更新表格，最后一個“GET”請求獲得所需信息。
我將再次感謝@QHarr 為我提供的所有幫助和時間！
JavaScript彈出窗口
聲明:本站的技術帖子網頁，遵循CC BY-SA 4.0協議，如果您需要轉載，請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.