您可以在发布请求期间提取详细文档的链接,然后使用internet explorer访问每个链接,确保提供正确的引用者标题;然后使用正则表达式获取该度量值。
TODO:代码确实需要重新考虑,因为主子级中有很多事情正在进行。实际上,每个子级/函数都应该做一件事。
Option Explicit
Public Sub GetDataZvgPort()
Const URL = "https://www.zvg-portal.de/index.php?button=Suchen"
Dim html As MSHTML.HTMLDocument, xhr As Object
Set html = New MSHTML.HTMLDocument
Set xhr = CreateObject("MSXML2.ServerXMLHTTP.6.0")
With xhr
.Open "POST", URL, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send "land_abk=ni&ger_name=Peine&order_by=2&ger_id=P2411"
html.body.innerHTML = .responseText
End With
Dim table As MSHTML.HTMLTable, r As Long, c As Long, headers(), row As MSHTML.HTMLTableRow
Dim results() As Variant, html2 As MSHTML.HTMLDocument
headers = Array("Aktenzeichen", "Amtsgericht", "Objekt/Lage", "Verkehrswert in â¬", "Termin", "Pdf-Link", "Addit Info Link", "m²")
ReDim results(1 To 100, 1 To UBound(headers) + 1)
Set table = html.querySelector("table")
Set html2 = New MSHTML.HTMLDocument
Dim lastRow As Boolean
For Each row In table.Rows
lastRow = False
Dim header As String
html2.body.innerHTML = row.innerHTML
header = Trim$(row.Children(0).innerText)
If header = "Aktenzeichen" Then 'start of new block. Assumes all blocks have this
r = r + 1
Dim dict As Scripting.Dictionary: Set dict = GetBlankDictionary(headers)
On Error Resume Next
dict("Addit Info Link") = Replace$(html2.querySelector("a").href, "about:", "https://www.zvg-portal.de/")
On Error GoTo 0
End If
If dict.Exists(header) Then dict(header) = Trim$(row.Children(1).innerText)
If (header = vbNullString And html2.querySelectorAll("a").Length > 0) Then
dict("Pdf-Link") = Replace$(html2.querySelector("a").href, "about:blank", "https://www.zvg-portal.de/index.php")
lastRow = True
ElseIf header = "Termin" Then
If row.NextSibling.NodeType = 1 Then lastRow = True
End If
If lastRow Then
populateArrayFromDict dict, results, r
End If
Next
results = Application.Transpose(results)
ReDim Preserve results(1 To UBound(headers) + 1, 1 To r)
results = Application.Transpose(results)
Dim re As Object
Set re = CreateObject("VBScript.RegExp")
With re
.Global = False
.MultiLine = False
.IgnoreCase = True
.Pattern = "\s([0-9.]+)\sm²"
End With
Dim ie As SHDocVw.InternetExplorer
Set ie = New SHDocVw.InternetExplorer
With ie
.Visible = True
For r = LBound(results, 1) To UBound(results, 1)
If results(r, 7) <> vbNullString Then
.Navigate2 results(r, 7), headers:="Referer: " & URL
While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
'On Error Resume Next
results(r, 8) = re.Execute(.document.querySelector("#anzeige").innerHTML)(0).Submatches(0)
'On Error GoTo 0
End If
Next
.Quit
End With
With ActiveSheet
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
End Sub
Public Sub populateArrayFromDict(ByVal dict As Scripting.Dictionary, ByRef results() As Variant, ByVal r As Long)
Dim key As Variant, c As Long
For Each key In dict.Keys
c = c + 1
results(r, c) = Replace$(dict(key), " (Detailansicht)", vbNullString)
Next
End Sub
Public Function GetBlankDictionary(ByRef headers() As Variant) As Scripting.Dictionary
Dim dict As Scripting.Dictionary, i As Long
Set dict = New Scripting.Dictionary
For i = LBound(headers) To UBound(headers)
dict(headers(i)) = vbNullString
Next
Set GetBlankDictionary = dict
End Function
