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.