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

问题描述

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

我想解析每个盒子的内容。可以使用 class name 找到该框的内容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

当我执行上述脚本时，它看起来运行顺利，但没有任何反应（我的意思是，没有点击）并且它也没有抛出任何错误。最后它优雅地退出浏览器。

这就是单击一个点时带有信息的框的样子。

尽管我在脚本中使用了硬编码延迟，但它们可以在宏开始工作后立即修复。

问题：如何单击该地图上的每个点并从弹出框中收集相关信息？我只希望有任何解决方案使用Internet Explorer

数据不是这里的主要关注点。我想知道 IE 在这种情况下是如何工作的，以便在将来的情况下处理它们。IE 以外的任何解决方案都不是我想要的。

标签： vbaexcelweb-scrapinginternet-explorer-11

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

JsonConverter的安装

下载最新版本
将 JsonConverter.bas 导入您的项目（打开 VBA 编辑器，Alt + F11；文件 > 导入文件）添加字典引用/类
仅限 Windows，包括对“Microsoft Scripting Runtime”的引用
对于 Windows 和 Mac，包括 VBA-Dictionary

待补充的参考资料

在此处下载示例文件。

代码：

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

输出

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

问题描述

解决方案

推荐阅读