Question

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

我想解析每个框的内容。可以使用类名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，我没有其他解决方案。

Answer 1

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

安装JsonConverter

下载latest release
将JsonConverter.bas导入项目（打开VBA编辑器，Alt + F11；文件>导入文件）添加字典参考/类
仅适用于Windows，请包含对“ Microsoft脚本运行时”的引用
对于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

输出

无法单击某些点以刮擦信息

1 个答案: