使用带进度追踪的Microsoft.XMLHTTP在VBA中上传至Azure Blob Storage报错

你的代码核心问题是没遵循Azure Blob分块上传的API规范，直接重复PUT到Blob主URL，既会覆盖之前的块，也不符合Azure的要求，导致xmlHttp.send报错。另外进度计算逻辑也有问题，下面是修正后的完整方案：

问题点拆解 #

1. 分块上传方式错误：Azure块Blob分块上传不能直接PUT到Blob地址，必须先上传单个块（带comp=block&blockid=参数），最后再提交块列表合并
2. 块ID缺失：每个块需要唯一的Base64编码ID，Azure靠这个识别不同块
3. 进度计算逻辑错误：原来的IntValue = (bytesSent \ chunkSize)在最后一块会计算错误
4. 字节数组处理冗余：adoStream.Read(chunkSize)会直接返回对应大小的字节数组，不需要提前ReDim

修正后的完整代码 #

Public Sub UploadToAzureBlob(filePath As String, fileName As String)
    Dim adoStream As Object
    Dim xmlHttp As Object
    Dim sUrl As String
    Dim fileSize As Long
    Dim bytesSent As Long
    Dim chunkSize As Long
    Dim fileData As Variant
    Dim progressForm As Form
    Dim numParts As Long
    Dim blockIds As Collection ' 存储所有块的Base64 ID
    Dim blockId As String
    Dim blockIndex As Integer
    
    ' 拼接完整文件路径和Blob地址
    filePath = filePath & fileName
    fileName = "/" & URLEncodeJScript(fileName)
    sUrl = blobUrl & fileName & sasToken

    ' 初始化ADODB流读取文件
    Set adoStream = CreateObject("ADODB.Stream")
    adoStream.Mode = 3
    adoStream.Type = 1
    adoStream.Open
    adoStream.LoadFromFile filePath
    fileSize = adoStream.Size
  
    ' 设置分块参数
    numParts = 5
    chunkSize = fileSize \ numParts
    If chunkSize = 0 Then chunkSize = fileSize ' 小文件不分块
    
    ' 打开进度窗体
    DoCmd.OpenForm "dlgPRGBAR"
    Set progressForm = Forms!dlgPRGBAR
    Set prg = progressForm!CtlProgress.Object
    Set Complete = progressForm!lblComplete
    prg.Max = 100 ' 直接用百分比更直观
    prg.Value = 0
    Complete.Caption = "0 % Complete"
    DoCmd.RepaintObject
    
    Set blockIds = New Collection
    
    bytesSent = 0
    blockIndex = 1
    Do While bytesSent < fileSize
        ' 调整最后一块的大小
        If bytesSent + chunkSize > fileSize Then
            chunkSize = fileSize - bytesSent
        End If
        
        ' 读取当前块数据
        adoStream.Position = bytesSent
        fileData = adoStream.Read(chunkSize)
        
        ' 生成唯一块ID（Base64编码，必须唯一）
        blockId = EncodeBase64("block-" & Format(blockIndex, "0000"))
        blockIds.Add blockId
        
        ' 创建XMLHTTP请求，上传单个块
        Set xmlHttp = CreateObject("Microsoft.XMLHTTP")
        xmlHttp.Open "PUT", sUrl & "&comp=block&blockid=" & blockId, False
        xmlHttp.setRequestHeader "Content-Length", CStr(chunkSize)
        
        ' 发送块数据
        xmlHttp.send fileData
        
        ' 检查上传状态
        If xmlHttp.status <> 201 Then
            Debug.Print "块上传错误: " & xmlHttp.status & " - " & xmlHttp.StatusText
            MsgBox "块上传错误: " & xmlHttp.status & " - " & xmlHttp.StatusText, vbCritical
            GoTo CleanUp
        End If
        
        ' 更新进度
        bytesSent = bytesSent + chunkSize
        prg.Value = Round((bytesSent / fileSize) * 100, 0)
        Complete.Caption = prg.Value & " % Complete"
        DoCmd.RepaintObject
        
        blockIndex = blockIndex + 1
        Set xmlHttp = Nothing
    Loop
    
    ' 提交块列表，合并所有块为完整Blob
    Set xmlHttp = CreateObject("Microsoft.XMLHTTP")
    xmlHttp.Open "PUT", sUrl & "&comp=blocklist", False
    xmlHttp.setRequestHeader "Content-Type", "application/xml"
    
    ' 构造块列表XML
    Dim blockListXml As String
    blockListXml = "<?xml version=""1.0"" encoding=""utf-8""?>" & vbCrLf
    blockListXml = blockListXml & "<BlockList>" & vbCrLf
    For Each blockId In blockIds
        blockListXml = blockListXml & "  <Latest>" & blockId & "</Latest>" & vbCrLf
    Next
    blockListXml = blockListXml & "</BlockList>"
    
    xmlHttp.send blockListXml
    If xmlHttp.Status = 201 Then
        MsgBox "文件上传成功!", vbInformation
    Else
        MsgBox "合并块错误: " & xmlHttp.Status & " - " & xmlHttp.StatusText, vbCritical
    End If
    
CleanUp:
    ' 清理资源
    On Error Resume Next
    If Not adoStream Is Nothing Then adoStream.Close
    Set adoStream = Nothing
    Set xmlHttp = Nothing
    Set blockIds = Nothing
    DoCmd.Close acForm, "dlgPRGBAR"
End Sub

' Base64编码函数（用于生成块ID）
Private Function EncodeBase64(inputStr As String) As String
    Dim bytes() As Byte
    bytes = StrConv(inputStr, vbFromUnicode)
    Dim objXML As Object
    Dim objNode As Object
    Set objXML = CreateObject("MSXML2.DOMDocument")
    Set objNode = objXML.createElement("base64")
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = bytes
    EncodeBase64 = Replace(objNode.Text, vbCrLf, "")
    Set objNode = Nothing
    Set objXML = Nothing
End Function

关键修正说明 #

• 块上传API：每个块的请求URL添加&comp=block&blockid={base64Id}，告诉Azure这是上传单个块
• 块ID生成：用EncodeBase64生成唯一的Base64编码ID，确保每个块唯一
• 进度计算：直接用(已传字节/总字节)*100计算百分比，避免分块数量导致的误差
• 块列表提交：所有块上传完成后，必须提交XML格式的块列表，Azure才会把块拼接成完整文件
• 资源清理：每次上传块后重新创建XMLHTTP对象，避免状态残留问题

内容的提问来源于stack exchange，提问作者MBMSOFT