"MSXML2.XMLHTTP"与“ADODB.Stream”结合下载HTTP上的文件

Question

"MSXML2.XMLHTTP"与“ADODB.Stream”结合下载HTTP上的文件程序是运行正常，很小的图片如1K左右没问题，大图片的话，文件保存时就会出问题，我看了下错误提示，似乎是因为不能一次性写入太长的byte数组。我是想把读到的流分批写入，但是不知道改如何去写。在运行到标红的代码时出现的问题。请各位大侠帮帮忙，谢谢！！源代码如下：
Function GetHttpFile(strHTTPPath As String) As String
If strHTTPPath <> "" Then
Dim a As Variant
Set a = createObject("MSXML2.XMLHTTP")
a.open "get", strHTTPPath, False
a.send

Dim b As Variant
Dim fso As Variant

Set b = createObject("ADODB.Stream")
b.Type = 1
b.open
Set fso = createObject("Scripting.FileSystemObject")
If a.status = 200 Then
b.Write a.responseBody
If fso.FileExists("d:\temp\userinfo.xls") Then
Call fso.DeleteFile("c:\temp\userinfo.xls", True)
End If
b.SaveToFile "c:\temp\userinfo.xls"
End If
b.Close
Set b = Nothing
Set fso = Nothing
End If
End Function

Answer 1

一个类Option ExplicitPrivate m_sFileName As String
Private m_sWebPage As String
Private m_sUserName As String
Private m_sPassWord As String
Private m_UploadMessage As StringPublic Property Let FileName(ByVal UploadFileName As String)
    m_sFileName = UploadFileName
End PropertyPublic Property Let WebPage(ByVal UploadWebPage As String)
    m_sWebPage = UploadWebPage
End PropertyPublic Property Let UserName(ByVal LoginName As String)
    m_sUserName = LoginName
End PropertyPublic Property Let LoginPsWd(ByVal PassWord As String)
    m_sPassWord = PassWord
End PropertyPublic Property Get Message() As String
    Message = m_UploadMessage
End PropertyPublic Function UploadFile() As Boolean
On Error GoTo UploadFile_Error    m_UploadMessage = ""
    If Len(m_sFileName) = 0 Then
        m_UploadMessage = "未设置上传的文件。"
        UploadFile = False
        Exit Function
    End If
    
    Dim XMLDocument As New DOMDocument
    Dim ADOStream As New Stream
    Dim DOMElement As IXMLDOMElement
    Dim MyXMLHttp As New XMLHTTP
    
    XMLDocument.loadXML ("<?xml version=""1.0"" ?> <root/>")
    XMLDocument.documentElement.setAttribute "xmlns:dt", "urn:schemas-microsoft-com:datatypes"
    Set DOMElement = XMLDocument.createElement("File")
    DOMElement.dataType = "bin.base64"
    ADOStream.Type = adTypeBinary
    ADOStream.Open
    ADOStream.LoadFromFile m_sFileName
    DOMElement.nodeTypedValue = ADOStream.Read
    ADOStream.Close
    XMLDocument.documentElement.appendChild DOMElement
    
    '请在下面再添加一个文件名的节点
    
    
    MyXMLHttp.Open "POST", m_sWebPage, False, m_sUserName, m_sPassWord
    MyXMLHttp.send XMLDocument
    m_UploadMessage = MyXMLHttp.responseText
    If m_UploadMessage = "OK" Then
        m_UploadMessage = ""
        UploadFile = True
    Else
        UploadFile = False
    End If
    
UploadFile_Exit:
    m_sFileName = ""
    Set XMLDocument = Nothing
    Set ADOStream = Nothing
    Set DOMElement = Nothing
    Set MyXMLHttp = Nothing
    Exit Function
    
UploadFile_Error:
    UploadFile = False
    Debug.Print CStr(Now()) & "--->" & vbCrLf & _
             "ErrAddress:  VanFileTransfer->VanFileDownLoad->UploadFile" & vbCrLf & _
             "ErrNumber:   " & Err.Number & vbCrLf & _
             "Description: " & Err.Description & vbCrLf
    Err.Clear
    Resume UploadFile_Exit
    
End Function