如何通过Excel VBA借助共享链接向SharePoint列表添加记录

我正尝试创建一个Excel用户窗体，用于向SharePoint列表添加新记录，该窗体需供组织内所有用户使用，无需为用户单独配置列表权限。SharePoint列表的基础URL仅我本人可访问，而SharePoint提供的共享链接测试用户可正常访问。我编写的VBA代码使用基础URL时自身可正常运行，但测试用户无法使用；将连接字符串替换为共享链接后，所有人都收到“找不到SubmissionsTest对象”的错误。

原VBA代码 #

Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim mySQL As String

Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset

mySQL = "SELECT * FROM SubmissionsTest;"

With cnt
    .ConnectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;WSS;IMEX=0;RetrieveIds=Yes;" _
    & "DATABASE=https://myorg.sharepoint.com/personal/myname/;LIST=SubmissionsTest;"
    .Open
End With
rst.Open mySQL, cnt, adOpenDynamic, adLockOptimistic

rst.AddNew
    rst.Fields("Title") = Int(Now() * 100000)
    rst.Fields("testEntry") = "This is a test submission"
    rst.Fields("testSubmitter") = Environ("UserName")
rst.Update

If CBool(rst.State And adStateOpen) = True Then rst.Close
If CBool(cnt.State And adStateOpen) = True Then cnt.Close

MsgBox "Your submission has been received."

1. 问题根源 #

• 使用个人站点URL时，测试用户无访问权限，导致连接失败。
• 替换为共享链接后，ACE OLEDB驱动无法识别共享链接格式，无法定位到目标列表，因此报错“找不到SubmissionsTest对象”。

2. 最优方案：改用SharePoint REST API #

ACE OLEDB驱动对共享链接支持有限，推荐使用SharePoint REST API实现无额外权限配置的记录提交，具体步骤：

• 确保列表共享链接设置为组织内所有人可编辑/提交；
• 用VBA发送POST请求到REST API端点，无需依赖ACE驱动。

3. 修改后的VBA代码 #

Sub SubmitToSPList()
    Dim xmlHttp As Object
    Dim listUrl As String
    Dim postData As String
    Dim userName As String
    Dim titleValue As String
    
    ' 替换为你的列表对应的REST端点（格式：站点URL/_api/web/lists/getbytitle('列表名')/items）
    listUrl = "https://myorg.sharepoint.com/personal/myname/_api/web/lists/getbytitle('SubmissionsTest')/items"
    
    userName = Environ("UserName")
    titleValue = Int(Now() * 100000)
    
    ' 构造JSON格式的提交数据，注意实体类型需与列表匹配
    postData = "{'__metadata': {'type': 'SP.Data.SubmissionsTestListItem'}, " & _
               "'Title': '" & titleValue & "', " & _
               "'testEntry': 'This is a test submission', " & _
               "'testSubmitter': '" & userName & "'}"
    
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    With xmlHttp
        .Open "POST", listUrl, False
        .SetRequestHeader "Accept", "application/json;odata=verbose"
        .SetRequestHeader "Content-Type", "application/json;odata=verbose"
        .SetRequestHeader "X-RequestDigest", GetRequestDigest(listUrl)
        .Send postData
        
        If .Status = 201 Then
            MsgBox "Your submission has been received."
        Else
            MsgBox "Submission failed: " & .Status & " - " & .responseText
        End If
    End With
End Sub

' 获取请求摘要，用于SharePoint验证POST请求
Function GetRequestDigest(siteUrl As String) As String
    Dim xmlHttp As Object
    Dim digestValue As String
    
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    With xmlHttp
        .Open "POST", Left(siteUrl, InStrRev(siteUrl, "/_api/")) & "_api/contextinfo", False
        .SetRequestHeader "Accept", "application/json;odata=verbose"
        .Send ""
        
        If .Status = 200 Then
            digestValue = Split(Split(.responseText, """FormDigestValue"":""")(1), """")(0)
        End If
    End With
    GetRequestDigest = digestValue
End Function

4. 关键说明 #

• REST端点构造：从列表共享链接提取站点基础URL，拼接/_api/web/lists/getbytitle('列表名')/items作为提交地址；
• 请求摘要：通过/_api/contextinfo获取FormDigestValue，这是SharePoint验证POST请求的必填参数；
• 实体类型：SP.Data.SubmissionsTestListItem为列表的专属实体类型，可通过访问站点URL/_api/web/lists/getbytitle('SubmissionsTest')查看ListItemEntityTypeFullName字段获取。

内容的提问来源于stack exchange，提问作者Allen R. Brady