用URLDownloadToFile從網上下載html文件創建空文件

Question

我有一個過去在這個論壇中討論過的問題，但是雖然已經提出了針對特定案例的解決方案，但沒有一個對我有用。 我想分析一個包含最近股票報價的數據表。正是這是一個雅虎組合。該網址是「https://finance.yahoo.com/portfolio/pf_5/view/view_0」。 如果我嘗試通過Web連接將組合導入到我的工作表中，則在導入窗口中不會顯示任何內容。這項工作很好，直到前段時間，但似乎雅虎已更改代碼，以便內容不能再導入。所以我不能使用Excel連接中的網站導入我的投資組合。

但我可以用Chrome下載文件，而無需輸入憑據（它們已經存儲在Chrome或Cookie中，不知道）到我的下載文件夾中作爲html文件，當我在瀏覽器中打開它時不僅會顯示像原始，但我也可以用Excel分析下載的文件。直接從瀏覽器下載的文件的文件長度爲256 kB。 因此，似乎服務器可以識別文件的使用方式並允許存儲它，但不能在線分析。

現在我正在嘗試編寫一個打開網站的vba子文件，下載該文件，然後分析存儲的版本。 分析部分工作正常，但我無法在代碼中包含工作下載。 當我使用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:\Users\xxx\Downloads\pf1 - 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:\Users\xxxx\Downloads\pf1 - 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

在等待一個答案我繼續尋找其他的解決方案，並找到了一個在我的情況下工作。這不是我一直在尋找的答案，但它解決了我的問題。 現在我正在使用Yahoo Finance API（see [Alternative to google finance api (closed)），而不是使用雅虎投資組合頁面。 網址

http://finance.yahoo.com/d/quotes.csv?s=symbol1[+symbol2+symbol3...]&f=format_code

創建可下載的逗號分隔的文本文件（.csv），其可以被存儲，或直接在VBA評價。 [符號1 ...]是你要分析的股票和 {格式代碼}的股票代碼是一系列的，你想看到（在http://www.jarloo.com/yahoo_finance/完整列表）

信其描述數據的類型由於我只需要股票代碼和沒有時間的最後價格，我的格式代碼是「sl1」。 雖然有，但實際上有兩個。 第一個（由雅虎實施）是允許的最大符號數爲200，如果您在短時間內撥打太多電話，您的IP可能會被阻止。所以實時流數據可能無法以這種方式獲得，儘管格式列表包含實時數據的代碼。

第二個是由QueryTables.Add給出的方法，我在下面的代碼中使用，它將URL限制爲255個字符。如果URL字符串較長，則會發生運行時錯誤。這意味着第二個限制將在達到200個符號之前發生。

以下代碼通過創建儘可能多的調用以獲取所有符號的數據來解決此問題，其中每個調用使用的URL長度少於256個字符。 在我的測試中，我使用兩張工作表test和pf1的工作簿test.xlsm。 PF1包含從第3行開始在列A中提取的所有符號列表。 工作表「test」中的第一行在D1（= 3）中具有這些數據的起始行，並且在E1中具有最後一個符號的行。

我的子文件有一個外部循環，它可以根據需要重複內部循環來獲取所有符號。

內部循環爲調用創建URL1，並將儘可能多的符號添加到URL的基本部分，條件是它必須保持在256個字符之內。一旦URL完整，實際指向符號列表保存爲「First」並且數據被提取。然後計算列表中下一批數據的新URL。

獲取所有數據後，結果表中的行高和列長被重置，因爲我注意到它們在操作過程中發生了變化（不知道爲什麼）。

我也注意到一些價格值，美國十進制格式（帶有小數點「點」）可能會在查詢過程中丟失點。不知道這是由於我的數字格式（歐洲，用「逗號」）還是由於查詢本身的問題。理想情況下，我的數字格式不應該有任何影響，因爲下載的數據應該全部是TEXT。無論如何，這使得有必要使用所有符號的近似價格值列表來校正最終的異常值。這個修正不包括在這個小節中。

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