Excel宏VBA从SharePoint下载文件异常：文件损坏无法打开求助

• 下载的文件仅4KB（原文件28KB），打开时提示「文件格式或扩展名无效，请验证文件未损坏」，但手动下载可正常打开。

相关信息 #

• SharePoint文件库地址：https://sandvik.sharepoint.com/team/PUMebaneDataHub/Shared%20Documents/Forms/Allitems.aspx
• 文件实际访问链接：https://sandvik.sharepoint.com/:x:/r/teams/PUMebaneDataHub/Shared%20Documents/Mebane%20Incident%20Intake%20Form.xlsx?d=w8031d09838fe4673854fa5241b259fca&csf=1&web=1&e=ty1IRb

原VBA代码 #

Option Explicit
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 

Sub DownloadFileFromWeb()
    Dim i As Integer
    Const strUrl As String = "https://sandvik.sharepoint.com/teams/PUMebaneDataHub/Shared%20Documents/Mebane Incident Intake Form.xlsx"
    Dim strSavePath As String 
    Dim returnValue As Long 
    strSavePath = "C:\temp1\Mebane Incident Intake Form.xlsx"
    returnValue = URLDownloadToFile(0, strUrl, strSavePath, 0, 0) 
End Sub 

解决方案 #

原因分析 #

URLDownloadToFile默认不会携带用户的SharePoint身份凭证，下载的其实是登录验证页面的HTML内容（大小约4KB），而非目标文件。

方案1：使用SharePoint直接下载链接 #

将文件的访问链接修改为直接下载格式：把原链接中的:/r/替换为:/x/download.aspx?sourceUrl=，并对原文件路径进行URL编码。修改后的链接示例：

https://sandvik.sharepoint.com/:x:/teams/PUMebaneDataHub/_layouts/15/download.aspx?sourceUrl=https%3A%2F%2Fsandvik.sharepoint.com%2Fteams%2FPUMebaneDataHub%2FShared%2520Documents%2FMebane%2520Incident%2520Intake%2520Form.xlsx&d=w8031d09838fe4673854fa5241b259fca

替换原代码中的strUrl即可。

方案2：使用MSXML2.XMLHTTP传递身份凭证 #

改用MSXML2.XMLHTTP对象，自动使用当前用户的Windows身份凭证（适用于域环境或已登录Office 365的场景），并通过二进制流写入文件：

Option Explicit

Sub DownloadSPFileWithAuth()
    Dim strUrl As String
    Dim strSavePath As String
    Dim http As Object
    Dim stream As Object
    
    strUrl = "https://sandvik.sharepoint.com/teams/PUMebaneDataHub/Shared%20Documents/Mebane%20Incident%20Intake%20Form.xlsx"
    strSavePath = "C:\temp1\Mebane Incident Intake Form.xlsx"
    
    ' 初始化HTTP对象
    Set http = CreateObject("MSXML2.XMLHTTP.6.0")
    http.Open "GET", strUrl, False
    ' 发送身份凭证
    http.setRequestHeader "Authorization", "Negotiate"
    http.send
    
    ' 验证请求状态并写入文件
    If http.Status = 200 Then
        Set stream = CreateObject("ADODB.Stream")
        stream.Type = 1 ' 二进制模式
        stream.Open
        stream.Write http.responseBody
        stream.SaveToFile strSavePath, 2 ' 2=覆盖现有文件
        stream.Close
        MsgBox "文件下载成功"
    Else
        MsgBox "下载失败，状态码：" & http.Status
    End If
    
    ' 释放对象
    Set stream = Nothing
    Set http = Nothing
End Sub

方案3：使用SharePoint Client Object Model（CSOM，推荐） #

对于SharePoint Online，CSOM是更稳定的方式，需先安装Microsoft SharePoint Client Components SDK并添加引用，代码示例：

Option Explicit

Sub DownloadSPFileWithCSOM()
    Dim siteUrl As String
    Dim serverRelativePath As String
    Dim savePath As String
    Dim clientContext As Object
    Dim web As Object
    Dim file As Object
    Dim fileStream As Object
    Dim outputStream As Object
    
    siteUrl = "https://sandvik.sharepoint.com/teams/PUMebaneDataHub"
    serverRelativePath = "/teams/PUMebaneDataHub/Shared Documents/Mebane Incident Intake Form.xlsx"
    savePath = "C:\temp1\Mebane Incident Intake Form.xlsx"
    
    ' 创建ClientContext并设置凭证
    Set clientContext = CreateObject("Microsoft.SharePoint.Client.ClientContext")(siteUrl)
    ' 若使用Office 365账号，需传入登录名和安全密码
    clientContext.Credentials = CreateObject("Microsoft.SharePoint.Client.SharePointOnlineCredentials")("your-account@sandvik.com", GetSecureString("your-password"))
    
    ' 获取文件并下载
    Set web = clientContext.Web
    Set file = web.GetFileByServerRelativeUrl(serverRelativePath)
    clientContext.Load(file)
    clientContext.ExecuteQuery
    
    Set fileStream = file.OpenBinaryDirect(clientContext)
    Set outputStream = CreateObject("ADODB.Stream")
    outputStream.Type = 1
    outputStream.Open
    outputStream.CopyFrom fileStream.Stream
    outputStream.SaveToFile savePath, 2
    outputStream.Close
    
    MsgBox "文件下载成功"
    
    ' 释放资源
    Set outputStream = Nothing
    Set fileStream = Nothing
    Set file = Nothing
    Set web = Nothing
    Set clientContext = Nothing
End Sub

' 生成安全字符串（用于密码）
Function GetSecureString(password As String) As Object
    Dim secureStr As Object
    Set secureStr = CreateObject("System.Security.SecureString")
    Dim i As Integer
    For i = 1 To Len(password)
        secureStr.AppendChar Mid(password, i, 1)
    Next i
    Set GetSecureString = secureStr
End Function

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