vba - 无法点击某些点来抓取信息

Question

我用 vba 结合 IE 编写了一个脚本，用于单击网页中 map 上的一些可用点。单击一个点时，会弹出一个包含相关信息的小框。

Link to that website

我想解析每个盒子的内容。可以使用类名 contentPane 找到该框的内容。然而，这里主要关注的是通过单击这些点来生成每个框。当出现一个框时，它看起来如下图所示。

这是我迄今为止尝试过的脚本:

Sub HitDotOnAMap()
    Const Url As String = "https://www.arcgis.com/apps/Embed/index.html?webmap=4712740e6d6747d18cffc6a5fa5988f8&extent=-141.1354,10.7295,-49.7292,57.6712&zoom=true&scale=true&search=true&searchextent=true&details=true&legend=true&active_panel=details&basemap_gallery=true&disable_scroll=true&theme=light"
    Dim IE As New InternetExplorer, HTML As HTMLDocument
    Dim post As Object, I&
    
    With IE
        .Visible = True
        .navigate Url
        While .Busy = True Or .readyState < 4: DoEvents: Wend
        Set HTML = .document
    End With
    
    Application.Wait Now + TimeValue("00:0:07")  ''the following line zooms in the slider
    HTML.querySelector("#mapDiv_zoom_slider .esriSimpleSliderIncrementButton").Click
    Application.Wait Now + TimeValue("00:0:04")
    
    With HTML.querySelectorAll("[id^='NWQMC_VM_directory_'] circle")
        For I = 0 To .Length - 1
            .item(I).Focus
            .item(I).Click
            Application.Wait Now + TimeValue("00:0:03")
            Set post = HTML.querySelector(".contentPane")
            Debug.Print post.innerText
            HTML.querySelector("[class$='close']").Click
        Next I
    End With
End Sub

when I execute the above script, it looks like it is running smoothly but nothing happens (I meant, no clicking) and it doesn't throw any error either. Finally it quits the browser gracefully.

这就是点击一个点时包含信息的框的样子。

Although I've used hardcoded delay within my script, they can be fixed later as soon as the macro starts working.

问题:如何单击 map 上的每个点并从弹出框中收集相关信息？我只希望使用 Internet Explorer

找到任何解决方案

The data are not the main concern here. I would like to know how IE work in such cases so that I can deal with them in future cases. Any solution other than IE is not I'm looking for.

Answer 1

无需点击每个点。 Json 文件包含所有详细信息，您可以根据您的要求提取。

<小时/>

JsonConverter的安装

1. 下载latest release
2. 将 JsonConverter.bas 导入到您的项目中(打开 VBA 编辑器，Alt + F11；文件 > 导入文件) 添加字典引用/类
3. 仅适用于 Windows，请包含对“Microsoft Scripting Runtime”的引用
4. 对于 Windows 和 Mac，包括 VBA 字典

<小时/>

待添加引用文献

<小时/>

下载示例文件 here .

<小时/>

代码:

Sub HitDotOnAMap()

    Const Url As String = "https://www.arcgis.com/sharing/rest/content/items/4712740e6d6747d18cffc6a5fa5988f8/data?f=json"
    Dim IE As New InternetExplorer, HTML As HTMLDocument
    Dim post As Object, I&
    Dim data As String, colObj As Object

    With IE
        .Visible = True
        .navigate Url
        While .Busy = True Or .readyState < 4: DoEvents: Wend
        data = .document.body.innerHTML
        data = Replace(Replace(data, "<pre>", ""), "</pre>", "")
    End With

    Dim JSON As Object
    Set JSON = JsonConverter.ParseJson(data)
    Set colObj = JSON("operationalLayers")(1)("featureCollection")("layers")(1)("featureSet")

    For Each Item In colObj("features")


         For j = 1 To Item("attributes").Count - 1
                Debug.Print Item("attributes").Keys()(j), Item("attributes").Items()(j)

         Next
    Next
End Sub

输出