正在从超链接图像中提取文件 URL
Extracting file URL from a Hyperlinked Image
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 从该图片下载文件。请指教。谢谢
您也许可以使用 POST (action="/pdq/SurveyOutputServlet") 直接点击表单目标,但它需要 元素的 post 字符串连同他们的价值观。大多数(如果不是全部)这些输入元素都已通过转到该页面为您填写。您需要做的就是收集它们并将它们连接成一个 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
您可能会将这段代码移动到某种循环中。相应地调整接收文件名。每个新页面都应该相应地调整自己的表单输入元素。
一旦响应存储在 HTMLDocument 对象中,您就可以使用
的 CSS 选择器
#download_xlsx
"#"
表示id。
然后您可以单击此元素
htmlDocument.querySelector("#download_xlsx").Click
VBA:
Option Explicit
Public Sub DownloadFile()
Dim ie As New InternetExplorer
With ie
.Visible = True
.navigate "https://data.bls.gov/timeseries/LNS14000000"
While .Busy Or .readyState < 4: DoEvents: Wend
.document.querySelector("#download_xlsx").Click
.Quit
End With
End Sub
其他:
您甚至可以定位表单并提交:
.document.forms("excel").submit
这会触发另一个答案中提到的 POST
请求(顺便说一句,这是一个很棒的答案)。
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 从该图片下载文件。请指教。谢谢
您也许可以使用 POST (action="/pdq/SurveyOutputServlet") 直接点击表单目标,但它需要 元素的 post 字符串连同他们的价值观。大多数(如果不是全部)这些输入元素都已通过转到该页面为您填写。您需要做的就是收集它们并将它们连接成一个 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 字符串并将其发回。
您可能会将这段代码移动到某种循环中。相应地调整接收文件名。每个新页面都应该相应地调整自己的表单输入元素。
一旦响应存储在 HTMLDocument 对象中,您就可以使用
的 CSS 选择器#download_xlsx
"#"
表示id。
然后您可以单击此元素
htmlDocument.querySelector("#download_xlsx").Click
VBA:
Option Explicit
Public Sub DownloadFile()
Dim ie As New InternetExplorer
With ie
.Visible = True
.navigate "https://data.bls.gov/timeseries/LNS14000000"
While .Busy Or .readyState < 4: DoEvents: Wend
.document.querySelector("#download_xlsx").Click
.Quit
End With
End Sub
其他:
您甚至可以定位表单并提交:
.document.forms("excel").submit
这会触发另一个答案中提到的 POST
请求(顺便说一句,这是一个很棒的答案)。