在 Excel VBA 中使用 XMLHTTP 下载网站的表格不起作用

Question

我正在尝试从以下网站下载历史黄金价格表： www.lbma.org.uk/prices-and-data/precious-metal-prices#/table

Dim http As MSXML2.XMLHTTP60 
Set http = New MSXML2.XMLHTTP60

With http
     .Open "GET", "https://www.lbma.org.uk/prices-and-data/precious-metal-prices#/table", True 
     .setRequestHeader "User-Agent", "Mozilla/5.0"
     .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
     .send

     Do  ' Wait till the page is loaded
        DoEvents
        Sleep (1)
    Loop Until .ReadyState = 4
End With

http.responseText 长 115kB，包含页面中的所有文本等，但没有包含黄金价格数据的实际表格。我对 xmlhttp 很陌生 - 知道我做错了什么吗？

Answer 1

这是一种仅拉动 AM 价格的方法，如果您愿意，这应该很容易扩展到拉 PM 价格。

我所做的是查看在此站点上发出的XHR 请求，并注意到它使用 JSON 将数据发送到页面以获取每个部分的价格。这可能是您在页面上找不到表格 HTML 的原因，它正在创建中。

为了获得此代码，您需要加载 VBA-JSON 项目。这是用来解析JSON的，你可以找到here。按照该页面上的说明进行添加

代码

Option Explicit

Public Function GetHistoricalGoldPricesJSON() As String
    On Error GoTo ErrHand:
    Const url As String = "https://prices.lbma.org.uk/json/gold_am.json?r=166366104"
    
    With CreateObject("MSXML2.XMLHTTP")
         .Open "GET", url, False
         .send
         GetHistoricalGoldPricesJSON = .ResponseText
    End With
    
    Exit Function
    
ErrHand:
    GetHistoricalGoldPricesJSON = ""
End Function

Public Function GetGoldPricesJSON(JsonString As String) As Object
    On Error Resume Next
    If JsonString = "" Then
        Set GetGoldPricesJSON= Nothing
        Exit Function
    End If
    
    Set GetGoldPricesJSON= JsonConverter.ParseJson(JsonString)
End Function

Public Sub GetGoldPrices()
    Dim GoldPrices As Object: Set GoldPrices = GetGoldPricesJSON(GetHistoricalGoldPricesJSON())
    
    'Nothing found or there was an error
    If GoldPrices Is Nothing Then Exit Sub
    
    Dim GoldPrice  As Variant
    Dim GoldArray  As Variant
    Dim Price      As Variant: ReDim GoldArray(1 To 50000, 1 To 4)
    Dim i          As Long
    
    For Each GoldPrice In GoldPrices
        i = i + 1
        GoldArray(i, 1) = GoldPrice("d")
        GoldArray(i, 2) = GoldPrice("v")(1)
        GoldArray(i, 3) = GoldPrice("v")(2)
        GoldArray(i, 4) = GoldPrice("v")(3)
    Next
    
    With ThisWorkbook.Sheets(1)
        .Cells.ClearContents
        .Range("A1:D1") = Array("Date", "USD AM Price", "GBP AM Price", "EUR AM Price")
        .Range(.Cells(2, 1), .Cells(i + 1, 4)) = GoldArray
    End With
    
End Sub