有没有办法使用excel vba从html响应文本中获取特定数据

Question

我不能手动完成，所以为它开发 vba；我的 VBA 代码适用于从网站抓取数据的状态字段，如快照所示。我能够获取状态数据，但无法提取在快照中突出显示的地址/位置。需要在网站的“E”列中为每个单独的访问代码（密码）添加它。我正在附加当前输出。我是新手。这是我在 E 列中需要的地址/位置字段的图像。（访问代码在 C 列）

这是我的 VBA 代码：

Option Explicit

Public Sub GetStatus()

On Error GoTo ErrHandler
    Dim html As MSHTML.HTMLDocument, xhr As Object, colourLkup As Object
    Dim ws As Worksheet, senhas(), i As Long, results()

Call CopyCommentText
    Set ws = ThisWorkbook.Worksheets("Client")
    senhas = Application.Transpose(ws.Range("C2:C" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row))

    ReDim results(1 To UBound(senhas))

    Set colourLkup = CreateObject("Scripting.Dictionary")
    colourLkup.Add "active1", "green"
    colourLkup.Add "active3", "orange"
    colourLkup.Add "valid", "valid"

    Set html = New MSHTML.HTMLDocument
    Set xhr = CreateObject("MSXML2.XMLHTTP")

    For i = LBound(senhas) To UBound(senhas)
        If senhas(i) <> vbNullString Then
            With xhr
                .Open "POST", "https://nacionalidade.justica.gov.pt/Home/GetEstadoProcessoAjax", False
                .setRequestHeader "User-Agent", "Mozilla/5.0"
                .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
                .send "SenhaAcesso=" & senhas(i)
                html.body.innerHTML = .responseText
            End With

            Dim nodes As Object, classinfo() As String

            Set nodes = html.querySelectorAll(".active1, .active3")

            classinfo = Split(nodes(nodes.Length - 1).className, Chr$(32))
            results(i) = Replace$(classinfo(1), "step", vbNullString) & "-" & colourLkup(classinfo(2))

 End If
        Set nodes = Nothing
    Next
    ws.Cells(2, 4).Resize(UBound(results), 1) = Application.Transpose(results)

ErrHandler:

'Error No. 1004 occurs in this case if worksheet with the same name already exists

If Err = 91 Then

'MsgBox "Invalid Code" & Chr(10) & Sheet1.Cells(i + 568, 4).Value & " " & "Row" & i + 568
classinfo(1) = "Invalid"
classinfo(2) = "Valid"


Resume Next
End If

Call CopyCommentText

Call Copy_With_AutoFilter1

End Sub

这是我已将访问代码隐藏的输出，因为它是机密的。

这是我使用调试打印的响应文本

Answer 1

尝试以下方法获取地址：

Public Sub GetAddress()
    Const pUrl$ = "https://nacionalidade.justica.gov.pt/Home/GetEstadoProcessoAjax"
    Dim Html As New HTMLDocument, Xhr As New XMLHTTP60
    Dim address$

    With Xhr
        .Open "POST", pUrl, False
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
        .send "SenhaAcesso=0908-1378-1843"
        Html.body.innerHTML = .responseText
    End With

    address = Html.querySelector("#block_container + div[style*='bold']").innerText

    MsgBox address
End Sub