vba - 从超链接图像中提取文件 URL

Question

Sub DownloadFile() 

    Dim myURL As String
    myURL = "http://data.bls.gov/timeseries/LNS14000000"
    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False, "username", "password"
    WinHttpReq.send

    myURL = WinHttpReq.responseBody
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile "C:\Downloads\abc.xlsx", 2
        oStream.Close
    End If

End Sub

我正在尝试使用 VBA 下载数据，发现此代码运行良好。我试图从中下载数据的网页 URL 是我在代码中使用的那个。请花点时间打开网页，因为我尝试下载的 Excel 文件链接在图像中，因此我无法找到从该图像下载文件的 URL。请指教。谢谢。

Answer 1

您可能可以使用 POST (action="/pdq/SurveyOutputServlet") 直接命中表单目标，但它需要 元素及其值的 post 字符串。只需转到该页面即可为您填写大多数(如果不是全部)这些输入元素。您需要做的就是收集它们并将它们连接成一个帖子字符串，然后将它们推回到表单中。

Option Explicit

'base web page
Public Const csBLSGOVpg = "http://data.bls.gov/timeseries/LNS14000000"
'form's action target
Public Const csXLSDLpg = "http://data.bls.gov/pdq/SurveyOutputServlet"

Sub mcr_Stream_Buyer_Documents()
    Dim xmlDL As New MSXML2.ServerXMLHTTP60, xmlBDY As New HTMLDocument, adoFILE As Object
    Dim xmlSend As String, strFN As String, f As Long, i As Long

    With xmlDL
        .SetTimeouts 5000, 5000, 15000, 25000

        'start by going to the base web page
        .Open "GET", csBLSGOVpg, False
        .setRequestHeader "Content-Type", "text/javascript"
        .send

        If .Status <> "200" Then GoTo bm_Exit

        'get the source HTML for examination; zero the post string var
        xmlBDY.body.innerHTML = .responseText
        xmlSend = vbNullString

        'loop through the forms until you find the right one
        'then loop through the input elements and construct a post string
        For f = 0 To xmlBDY.getElementsByTagName("form").Length - 1
            If xmlBDY.getElementsByTagName("form")(f).Name = "excel" Then
                With xmlBDY.getElementsByTagName("form")(f)
                    For i = 0 To .getElementsByTagName("input").Length - 1
                        xmlSend = xmlSend & Chr(38) & _
                                 .getElementsByTagName("input")(i).Name & Chr(61) & _
                                 .getElementsByTagName("input")(i).Value
                    Next i
                    xmlSend = "?.x=5&.y=5" & xmlSend
                End With
                Exit For
            End If
        Next f
        'Debug.Print xmlSend   'check the POST string

        'send the POST string back to the form's action target
        .Open "POST", csXLSDLpg, False
        xmlDL.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        xmlDL.send xmlSend

        If xmlDL.Status <> "200" Then GoTo bm_Exit

        'pick up the response as a stream and save it as a .XLSX
        strFN = Environ("USERPROFILE") & "\Documents\LNS14000000" & Format(Date, "yyyymmdd") & ".xlsx"
        On Error Resume Next
        Kill strFN
        On Error GoTo 0
        Set adoFILE = CreateObject("ADODB.Stream")
        adoFILE.Type = 1
        adoFILE.Open
        adoFILE.Write .responseBody
        adoFILE.SaveToFile strFN, 2
        Set adoFILE = Nothing

    End With
    Set xmlBDY = Nothing
    Set xmlDL = Nothing
    Exit Sub
bm_Exit:
    Debug.Print Err.Number & ":" & Err.Description
End Sub

这是非常简约的，但它就是你所需要的。至少有一个非标准输入元素没有名称，但我还是选择将其值发回。我没有按顺序移除东西，直到它坏了；我只是根据我检索到的内容构建了 POST 字符串并将其发回。


LNS1400000020150916.xlsx

您可能会将此代码移动到某种循环中。相应地调整接收文件名。每个新页面都应该相应地调整自己的表单输入元素。