VBA通过文件对话框上传文件至SharePoint遇404错误求助

问题根源分析 #

出现404错误的核心原因是未使用SharePoint REST API的标准上传端点，直接POST到文件夹+文件名的URL不符合SharePoint的API规范，同时代码中缺少必要的请求头，URL构造也存在潜在问题。

具体修正方案 #

1. 使用标准REST API上传端点 #

SharePoint REST API上传文件的正确端点格式为：

{站点URL}/_api/web/getfolderbyserverrelativeurl('{服务器相对文件夹路径}')/files/add(overwrite=true,url='{文件名}')

其中：

• 服务器相对文件夹路径：对应你的站点为/sites/SECS-Department/Shared Documents/Images
• overwrite=true表示若文件已存在则覆盖，可根据需求改为false

2. 修正代码中的URL构造 #

替换原代码中SharePointURL的构造逻辑，直接使用标准API端点：

' 可直接指定站点URL，或从TableDef中正确提取（确保提取的是站点根URL）
Dim siteUrl As String
siteUrl = "https://webname365.sharepoint.com/sites/SECS-Department"

' 构造标准API上传端点
Dim apiUploadUrl As String
apiUploadUrl = siteUrl & "/_api/web/getfolderbyserverrelativeurl('/sites/SECS-Department/Shared Documents/Images')/files/add(overwrite=true,url='" & newFileName & "')"

3. 添加必要的请求头 #

SharePoint REST API要求上传二进制文件时指定Content-Type，部分场景还需要X-RequestDigest令牌（针对经典认证或非匿名站点）。修改请求部分代码：

Dim client As Object
Set client = CreateObject("MSXML2.XMLHTTP.6.0")

With client
    .Open "POST", apiUploadUrl, False
    ' 指定二进制文件的Content-Type
    .setRequestHeader "Content-Type", "application/octet-stream"
    
    ' （可选）如果站点需要请求摘要，先获取X-RequestDigest令牌
    ' 以下是获取令牌的代码，可根据实际情况添加
    ' Dim digestClient As Object
    ' Set digestClient = CreateObject("MSXML2.XMLHTTP.6.0")
    ' digestClient.Open "POST", siteUrl & "/_api/contextinfo", False
    ' digestClient.send ""
    ' Dim xmlDoc As Object
    ' Set xmlDoc = CreateObject("MSXML.DOMDocument")
    ' xmlDoc.LoadXML digestClient.responseText
    ' Dim digest As String
    ' digest = xmlDoc.SelectSingleNode("//d:FormDigestValue").Text
    ' .setRequestHeader "X-RequestDigest", digest
    
    .send ado.read
    ado.Close
    
    Debug.Print .responseText
    If .Status = 200 Or .Status = 201 Then ' 201表示创建成功
        MsgBox "Upload completed successfully"
    Else
        MsgBox .Status & ": " & .StatusText
    End With

4. 验证文件名合法性 #

确保newFileName不包含SharePoint禁止的字符：/:*?"<>|，原代码中的ReplaceSpecialChars函数需确保处理这些字符。

完整修正后的代码 #

Private Sub uploadImage_Click()
    Dim ado As Object
    Dim ofd As Object
    Dim filePath As String
    Dim strExt As String
    Dim newFileName As String
    Dim siteUrl As String
    Dim apiUploadUrl As String

    ' 直接指定SharePoint站点URL（或从TableDef中正确提取）
    siteUrl = "https://webname365.sharepoint.com/sites/SECS-Department"

    Set ofd = Application.FileDialog(3)
    ofd.AllowMultiSelect = False
    ofd.Show

    If ofd.SelectedItems.Count = 1 Then
        filePath = ofd.SelectedItems(1)
        strExt = Mid(ofd.SelectedItems(1), InStrRev(ofd.SelectedItems(1), "."))

        If strExt = ".jpeg" Then
            strExt = ".jpg"
        End If
        
        newFileName = ReplaceSpecialChars(Me.itemName.Value, "-") & "_" & ReplaceSpecialChars(Nz(Me.Model.Value, ""), "-") & strExt
        ' 额外处理SharePoint禁止的文件名字符
        newFileName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(newFileName, ":", "-"), "*", "-"), "?", "-"), """", "-"), "<", "-"), ">", "-"), "|", "-")

        Debug.Print filePath
        Debug.Print newFileName
        Debug.Print siteUrl
 
        Set ado = CreateObject("ADODB.Stream")
        With ado
            .Type = 1 'binary
            .Open
            .LoadFromFile filePath
            .Position = 0
        End With

        Dim client As Object
        Set client = CreateObject("MSXML2.XMLHTTP.6.0")
        With client
            ' 构造标准API上传端点
            apiUploadUrl = siteUrl & "/_api/web/getfolderbyserverrelativeurl('/sites/SECS-Department/Shared Documents/Images')/files/add(overwrite=true,url='" & newFileName & "')"
            .Open "POST", apiUploadUrl, False
            .setRequestHeader "Content-Type", "application/octet-stream"
            
            ' （可选）添加请求摘要令牌（如果站点要求）
            ' Dim digestClient As Object
            ' Set digestClient = CreateObject("MSXML2.XMLHTTP.6.0")
            ' digestClient.Open "POST", siteUrl & "/_api/contextinfo", False
            ' digestClient.send ""
            ' Dim xmlDoc As Object
            ' Set xmlDoc = CreateObject("MSXML.DOMDocument")
            ' xmlDoc.LoadXML digestClient.responseText
            ' Dim digest As String
            ' digest = xmlDoc.SelectSingleNode("//d:FormDigestValue").Text
            ' .setRequestHeader "X-RequestDigest", digest
            
            .send ado.read
            ado.Close
            
            Debug.Print .responseText
            If .Status = 200 Or .Status = 201 Then
                MsgBox "Upload completed successfully"
            Else
                MsgBox .Status & ": " & .StatusText
            End If
        End With
    Else
        MsgBox "Image update Cancel!"
    End If
End Sub

' 确保ReplaceSpecialChars函数正确处理特殊字符
Private Function ReplaceSpecialChars(strInput As String, strReplaceWith As String) As String
    Dim arrSpecialChars As Variant
    arrSpecialChars = Array(" ", "!", "@", "#", "$", "%", "^", "&", "*", "(", ")", "+", "=", "[", "]", "{", "}", "\", "/", "?", ".", ",", ";", ":", "'", """", "<", ">", "|")
    
    Dim char As Variant
    For Each char In arrSpecialChars
        strInput = Replace(strInput, char, strReplaceWith)
    Next char
    
    ReplaceSpecialChars = strInput
End Function

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