Question

我在工作表上使用WEBSERVICE函数从XML文件获取数据。除公司策略默认情况下会阻止WEBSERVICE公式外，是否还有其他替代方法，因此每次我打开工作簿（启用内容）时都必须手动启用它。

我目前正在使用WEBSERVICE从Google地图接收距离和行驶时间。

Google Maps XML的输出：

down

我想将此输出粘贴到工作表中，从那里我可以获取值并进一步使用它们。

此外，我想从欧洲央行获得汇率。 https://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml

WEBSERVICE根本不适用于ECB XML，例如，因为它被公司策略阻止了。因此，我在想，如果工作簿中的此操作有替代的VBA功能，将以某种方式有所帮助。

编辑：

在QHarr的帮助下，它开始工作了：

hierarchies

剩下的唯一问题是如何将其像粘贴到原始XML文件中一样，使其看起来像在Excel表中，从单元格A1（不是一个单元格中的整个XML）开始：

---------------
    up | down
---------------
    5  |  1
---------------
    5  |  2

Answer 1

1）使用后期绑定的html文件

在给定您已注意到的限制的情况下，故意使用后期绑定引用设置以下内容。

Option Explicit

Public Sub GetRates()
    Dim headers(), r As Long, html As Object, listings As Object, re As Object, p As String
    p = "time=""(.*?)"""
    Set re = CreateObject("VBScript.RegExp")

    headers = Array("currency", "rate")
    Set html = CreateObject("htmlfile")

    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "GET", "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml", False
        .send
        html.body.innerHTML = .responseText
    End With

    Set listings = html.getElementsByTagName("Cube")
    Dim results(), item As Long, dateVar As String
    ReDim results(1 To 50, 1 To 2)
    For item = 2 To listings.Length - 1
        r = r + 1
        results(r, 1) = listings(item).getAttribute("currency")
        results(r, 2) = listings(item).getAttribute("rate")
    Next
    With ThisWorkbook.Worksheets("Sheet1")
        With re
            .Global = True
            .Pattern = p
            dateVar = .Execute(listings(0).outerHTML)(0).SubMatches(0)
        End With
        .Cells(1, 1) = dateVar
        .Cells(3, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(4, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

2）使用xml解析器。偏好。

Option Explicit
Public Sub test()
    Const URL As String = "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml"
    Dim sResponse As String, xmlDoc As Object    'MSXML2.DOMDocument60

    Set xmlDoc = CreateObject("MSXML2.DOMDocument") 'New MSXML2.DOMDocument60

    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "GET", URL, False
        .send
        sResponse = .responseText
    End With

    With xmlDoc
        .validateOnParse = True
        .setProperty "SelectionLanguage", "XPath"
        .async = False

        If Not .LoadXML(sResponse) Then
            Err.Raise .parseError.ErrorCode, , .parseError.reason
        End If

        Dim dateVar As String, results(), rates As Object, rate As Object, r As Long
        dateVar = xmlDoc.SelectSingleNode("//@time").Text
        Set rates = xmlDoc.SelectNodes("//*[@currency]")
        ReDim results(1 To rates.Length, 1 To 2)
        For Each rate In rates
            r = r + 1
            results(r, 1) = rate.getAttribute("currency")
            results(r, 2) = rate.getAttribute("rate")
        Next
        Dim headers()
        headers = Array("currency", "rate")
        With ThisWorkbook.Worksheets("Sheet1")
            .Cells(1, 1) = dateVar
            .Cells(3, 1).Resize(1, UBound(headers) + 1) = headers
            .Cells(4, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
        End With
    End With
End Sub

替代WEBSERVICE公式（VBA函数）

1 个答案:

1）使用后期绑定的html文件

2）使用xml解析器。偏好。