Question

我正在尝试从互联网上下载Excel文件，然后从中提取数据。问题是我没有收到任何错误，但下载的文件只有1kb。提取位有效，但文件为空。实际文件大小为350KB。

    Sub ExtractDataTest()

    Dim FileNum As Long
    Dim FileData() As Byte
    Dim MyFile As String
    Dim WHTTP As Object

    On Error Resume Next
        Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5")
        If Err.Number <> 0 Then
            Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
        End If
    On Error GoTo 0

    MyFile = "http://enhanced1.sharepoint.hs.com/teams/"

    WHTTP.Open "GET", MyFile, False
    WHTTP.Send
    FileData = WHTTP.ResponseBody
    Set WHTTP = Nothing

    If Dir("C:\xampp\htdocs\test", vbDirectory) = Empty Then MsgBox "No folder exist"

    FileNum = FreeFile
    Open "C:\xampp\htdocs\test\DE_TrackingSheet.xlsx" For Binary Access Write As #FileNum
        Put #FileNum, 1, FileData
    Close #FileNum

    Dim FilePath$, Row&, Column&, Address$

 'change constants & FilePath below to suit
     '***************************************
    Const FileName$ = "DE_TrackingSheet.xlsx"
    Const SheetName$ = "Open"
    Const NumRows& = 50
    Const NumColumns& = 20
    FilePath = ("C:\xampp\htdocs\test\")
     '***************************************

    DoEvents
    Application.ScreenUpdating = False
     If Dir(FilePath & FileName) = Empty Then
        MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
        Exit Sub
        End If
    For Row = 1 To NumRows
        For Column = 1 To NumColumns
            Address = Cells(Row, Column).Address
            Cells(Row, Column) = GetData(FilePath, FileName, SheetName, Address)
            Columns.AutoFit
        Next Column
    Next Row
    ActiveWindow.DisplayZeros = False
End Sub


Private Function GetData(Path, File, Sheet, Address)
    Dim Data$
    Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _
    Range(Address).Range("A1").Address(, , xlR1C1)
    GetData = ExecuteExcel4Macro(Data)
End Function

Answer 1

它可能是数据是二进制的事实;

....
WHTTP.Open "GET", MyFile, False
WHTTP.Send

Set strm = CreateObject("ADODB.Stream")
With strm
    .Type = 1
    .Open
    .Write WHTTP.ResponseBody
    .SaveToFile "C:\null\df.xlsx", 2 '//2==overwrite
End With
Set WHTTP = Nothing

VBA：下载文件

1 个答案: