0

我正在尝试从 Internet 下载 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
4

1 回答 1

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
于 2012-12-20T16:21:29.900 回答