VBA从SharePoint下载文件后文件损坏问题求助

问题说明 #

你的VBA代码执行无报错，但下载的文件无法打开、提示损坏，用记事本查看发现包含HTML代码——这是因为直接使用SharePoint的页面URL下载时，URLDownloadToFile获取到的是文件的预览网页，而非真实的文件内容。

核心原因 #

SharePoint的普通文件URL是网页预览地址，并非直接指向文件资源；同时URLDownloadToFile无法自动处理SharePoint的身份验证和跳转逻辑，导致最终下载到的是网页组件而非目标文件。

解决方案 #

1. 获取正确的直接下载链接 #

• 打开SharePoint文件页面，点击「下载」按钮，右键复制下载链接（不要复制浏览器地址栏的URL）
• 手动构造规则：
  • 若原URL带有?web=1后缀，替换为?download=1
  • 现代SharePoint的直接下载链接格式通常为：https://[站点域名]/sites/[站点名]/_layouts/15/download.aspx?SourceUrl=[文件的绝对路径]

2. 修改VBA代码（改用XMLHTTP处理身份验证和下载） #

替换原有的URLDownloadToFile声明和DownloadFile函数，使用MSXML2.XMLHTTP对象——它能自动复用当前Windows用户的SharePoint登录凭据，正确获取文件二进制内容：

Option Explicit

Function DownloadFile(Url As String, SavePathName As String) As Boolean
    Dim xmlHttp As Object
    Dim fso As Object
    Dim ts As Object
    
    On Error GoTo ErrorHandler
    
    ' 创建XMLHTTP对象
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    xmlHttp.Open "GET", Url, False
    ' 自动使用当前用户凭据发送请求
    xmlHttp.setRequestHeader "Authorization", "Negotiate"
    xmlHttp.send
    
    ' 检查请求是否成功
    If xmlHttp.Status = 200 Then
        ' 创建文件系统对象写入二进制内容
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.CreateTextFile(SavePathName, True, False)
        ts.Write xmlHttp.responseBody
        ts.Close
        DownloadFile = True
    Else
        DownloadFile = False
    End If
    
    Exit Function
    
ErrorHandler:
    DownloadFile = False
    MsgBox "下载出错：" & Err.Description, vbCritical
End Function

Sub Demo()
    Dim strUrl As String, strSavePath As String, strFile As String
    ' 替换为你的SharePoint直接下载链接
    strUrl = "https://xxx.sharepoint.com/sites/xxx/_layouts/15/download.aspx?SourceUrl=https://xxx.sharepoint.com/sites/xxx/Documents/CompanySalesReport.xlsx"
    strSavePath = "C:\Users\username\Desktop\"
    strFile = "CompanySalesReport.xlsx"
    
    ' 检查保存文件夹是否存在
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(strSavePath) Then
        MsgBox "保存路径不存在：" & strSavePath, vbCritical
        Exit Sub
    End If
    
    If DownloadFile(strUrl, strSavePath & strFile) Then
        MsgBox "文件已保存至：" & vbNewLine & strSavePath & strFile
    Else
        MsgBox "无法下载文件，请检查链接和权限", vbCritical
    End If
End Sub

注意事项 #

• 确保当前Windows用户已登录SharePoint且拥有该文件的下载权限
• 保存路径必须存在，代码中已加入文件夹存在性检查
• 若使用旧版Office，可将MSXML2.XMLHTTP.6.0改为MSXML2.XMLHTTP

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