使用URLDownloadToFile从Web下载html文件创建空文件

Question

我有一个问题，过去在这个论坛上讨论过，但是尽管已经提出了针对特定情况的解决方案，但没有一个对我有用。 我想分析一个包含最近股票报价的数据表。这正是雅虎的投资组合。网址为"https://finance.yahoo.com/portfolio/pf_5/view/view_0"。 如果我尝试通过网络连接将作品集导入我的工作表，则导入窗口中看不到任何内容。直到前段时间，这工作正常，但似乎雅虎已经更改了代码，因此无法再导入内容。因此，我无法再在Excel连接中使用该网站来导入我的作品集。

但是我可以使用Chrome将文件下载，而无需输入凭据(它们已经存储在Chrome或cookie中，不知道)作为html文件到我的下载文件夹中，当我在浏览器中打开它时，它不仅会显示原始文件，而且我还可以使用Excel分析下载的文件。直接从浏览器下载的文件的文件长度为 256 kB。 因此，服务器似乎可以识别文件的使用方式并允许存储它，但不能在线分析它。

现在我正在尝试编写一个 vba sub 来打开网站，下载文件，然后分析存储的版本。 分析部分工作正常，但我无法在代码中包含工作下载。 当我使用 URLDownloadToFile(0， URL1， URL2， 0， 0) 方法(URL1 是 https 地址，URL2 是文件名和路径)时，下载的文件只有 75kB 并且包含一些 java 代码，但是当我使用浏览器观看它并尝试将内容导入 Excel 时，屏幕上看不到任何数据， 不会导入任何内容。 因此，虽然URLDownloadToFile在大多数情况下可能有效，但它不适用于雅虎投资组合网页。 我的问题是： 1)它可以帮助更改函数的参数(参数1 = pcaller？但是怎么做呢？ 2)VBA中是否有任何其他已知方法可以在不逐行读取网页的情况下保存网页(也尝试过并且也不起作用)？ 这是我尝试过的两种方法：

Option Explicit
'Declarations
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
'Download Code
Sub download()
Dim done
Dim URL1 As String
Dim URL2 As String
URL1 = "https://finance.yahoo.com/portfolio/pf_5/view/v1"
URL2 = "C:UsersxxxDownloadspf1 - Yahoo Finance Portfolios.html"
'This will provide a return value to test.
'Note the  (   )  around the args
done = URLDownloadToFile(0, URL1, URL2, 0, 0)
'Test.
If done = 0 Then
MsgBox "File has been downloaded!"
Else
MsgBox "File not found!"
End If
End Sub

---

Sub SaveWebFile()   'this creates an "empty" file!
Dim URL1 As String
Dim URL2 As String
URL1 = "https://finance.yahoo.com/portfolio/pf_5/view/v1"
URL2 = "C:UsersxxxxDownloadspf1 - Yahoo Finance Portfolios.html"
Set fso = CreateObject("Scripting.fileSystemObject")
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL1, False
.send
Text = .responseText
End With
Set objOutputFile = fso.CreateTextFile(URL2, True)
objOutputFile.Write Text
objOutputFile.Close
End Sub

Answer 1

在等待答案的同时，我继续寻找其他解决方案，并找到了适合我的解决方案。这不是我一直在寻找的答案，但它解决了我的问题。 我现在不再使用雅虎投资组合页面，而是使用雅虎财经API(请参阅[谷歌财经API的替代品(已关闭))。 网址

http://finance.yahoo.com/d/quotes.csv?s=symbol1[+符号2+符号3...]&f=format_code

创建一个可下载的逗号分隔文本文件 (.csv)，该文件可以直接在 VBA 中存储或评估。 [symbol1 ...] 是您要分析的股票的股票代码，并且 {格式代码} 是一系列字母，用于描述要查看的数据类型(http://www.jarloo.com/yahoo_finance/中的完整列表)

由于我只需要股票代码和没有时间的最后价格，我的格式代码是"sl1"。 不过，有一个问题，或者实际上是两个问题。 第一个(由雅虎强加)是允许的最大符号数为 200，如果您在短时间内拨打太多电话，您的 IP 可能会被阻止。因此，尽管格式列表包含实时数据的代码，但可能无法以这种方式获取实时流数据。

第二个是由我在下面的代码中使用的QueryTables.Add方法给出的，该方法将 URL 限制为 255 个字符。如果 URL 字符串较长，则会发生运行时错误。这意味着第二个限制将在达到 200 个符号之前发生。

以下代码通过创建尽可能多的调用来提取所有符号的数据，其中每个调用使用长度小于 256 个字符的 URL，从而通过循环结构解决此问题。 在我的测试中，我使用工作簿test.xlsm和两个工作表test和pf1。 PF1 包含要从第 3 行开始的 A 列中获取的所有符号的列表。 工作表"test"中的第一行在 D1 (=3) 中具有这些数据的起始行，在 E1 中具有最后一个符号的行。

我的子有一个外循环，它根据需要重复内循环以获取所有符号。

内部循环为调用创建 URL1，向 URL 的基部分添加尽可能多的符号，条件是它必须保持在 256 个字符以下。URL 完成后，指向符号列表的实际指针将另存为"First"并获取数据。然后，为列表中的下一批数据计算一个新 URL。

获取所有数据后，结果表中的行高和列长度将被重置，因为我注意到它们在操作过程中发生了变化(不知道为什么)。

我还注意到，一些采用美国十进制格式(带有十进制"点")的价格值可能会在查询过程中丢失点。不确定这是由于我的数字格式(欧洲，带"逗号")还是查询本身的某些问题。理想情况下，我的数字格式应该没有任何影响，因为下载的数据应该都是文本。无论如何，这使得有必要使用所有交易品种的近似价格值列表来纠正最终异常值。此更正不包括在此子项中。

Sub Import_CSV_File_From_URL()
Dim URL1 As String
Dim URL As String
Dim ws As Worksheet
Dim First As Long
Dim Last As Long
Dim i As Long
Dim URLlen As Long
Dim NxtLen As Long
Dim destCell As Range
Dim qt As QueryTable

Set ws = ActiveSheet
URL = "http://finance.yahoo.com/d/quotes.csv?s="
First = ws.Range("D1")
Last = ws.Range("E1")
i = First
Do While i < Last                           'loop through all symbols
ws.Range("A" & First & ":Z1000").Clear  'clear all cells otherwise query inserts new columns.
Set destCell = Worksheets("test").Range("A" & First)
URL1 = URL
For i = First To Last
If i > First Then
URL1 = URL1 & "+"
End If
URL1 = URL1 & Worksheets("pf1").Range("A" & i)                      'add up to 200 symbols but
If Len(URL1) > 249 - Len(Worksheets("pf1").Range("A" & i + 1)) Then 'len(URL1) cannot be >255!!
First = i + 1       'save index for next batch of symbols
Exit For
End If
Next i
URL1 = URL1 & "&f=sl1"         'format "sl1": get symbol & last Trade for these tickers
With destCell.Parent.QueryTables.Add(Connection:="TEXT;" & URL1, Destination:=destCell)
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.PreserveFormatting = True
.Refresh BackgroundQuery:=False
End With
For Each qt In ActiveSheet.QueryTables
If qt.Refreshing Then qt.CancelRefresh
qt.Delete                                       'delete internal query tables
Next    
Loop        'add next batch of symbols
ws.Range("A:B").ColumnWidth = 8
For i = 3 To Last
ws.Rows(i).RowHeight = 15
Next i
End Sub