如何通过Outlook VBA将MailItem保存至SharePoint Online

方案1：本地临时文件 + SharePoint REST API上传 #

无需同步SP库到本地，直接通过API上传，适用性更广。

步骤：

1. 将选中的邮件保存到本地临时目录
2. 读取临时文件的二进制内容
3. 通过SharePoint REST API将文件上传到目标库

代码示例：

Sub SaveSelectedMailToSPOnline()
    Dim olkMsg As Outlook.MailItem
    Dim tempPath As String
    Dim tempFileName As String
    Dim spSiteUrl As String
    Dim spLibraryRelativeUrl As String
    Dim targetFileName As String
    Dim xmlHttp As Object
    Dim fileContent As Byte()
    Dim adoStream As Object
    
    ' 配置参数
    spSiteUrl = "https://MyCompany.sharepoint.com/sites/MyTeam"
    spLibraryRelativeUrl = "/Shared Documents/TestArchives"
    ' 可根据邮件信息动态生成文件名，避免重名
    targetFileName = Replace(Replace(olkMsg.Subject, "/", "-"), ":", "-") & ".msg"
    
    ' 获取系统临时路径
    tempPath = Environ("TEMP") & "\"
    tempFileName = tempPath & targetFileName
    
    ' 处理选中的邮件
    For Each olkMsg In Outlook.ActiveExplorer.Selection
        ' 保存邮件到临时文件
        olkMsg.SaveAs tempFileName, olMSG
        
        ' 读取文件二进制内容
        Set adoStream = CreateObject("ADODB.Stream")
        adoStream.Type = 1 ' 二进制模式
        adoStream.Open
        adoStream.LoadFromFile tempFileName
        fileContent = adoStream.Read
        adoStream.Close
        
        ' 构造REST上传请求地址
        Dim uploadUrl As String
        uploadUrl = spSiteUrl & "/_api/web/getfolderbyserverrelativeurl('" & Replace(spLibraryRelativeUrl, "/", "%2F") & "')/files/add(overwrite=true,url='" & targetFileName & "')"
        
        Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
        xmlHttp.Open "POST", uploadUrl, False
        xmlHttp.setRequestHeader "Accept", "application/json;odata=verbose"
        xmlHttp.setRequestHeader "Content-Type", "application/octet-stream"
        ' 域环境下启用NTLM身份验证，自动使用当前用户权限
        xmlHttp.setOption 2, 13056
        
        ' 发送上传请求
        xmlHttp.send fileContent
        
        ' 验证上传结果
        If xmlHttp.Status = 200 Or xmlHttp.Status = 201 Then
            MsgBox "邮件已成功保存到SharePoint"
        Else
            MsgBox "上传失败，错误码：" & xmlHttp.Status & vbCrLf & xmlHttp.responseText
        End If
        
        ' 清理临时文件
        Kill tempFileName
    Next olkMsg
End Sub

说明：

• 若公司使用OAuth身份验证，需补充实现GetSPAccessToken函数获取令牌，替换掉NTLM验证的代码行。
• 文件名需处理非法字符，避免上传失败。

方案2：利用SharePoint本地同步文件夹 #

如果已通过OneDrive for Business同步目标SP库到本地，可直接将临时文件复制到同步文件夹，系统会自动同步到云端。

代码示例：

Sub SaveSelectedMailToSPLocalSync()
    Dim olkMsg As Outlook.MailItem
    Dim tempPath As String
    Dim tempFileName As String
    Dim spSyncFolder As String
    Dim safeSubject As String
    
    ' 替换为实际的本地同步文件夹路径
    spSyncFolder = "C:\Users\YourUsername\OneDrive - MyCompany\MyTeam\Shared Documents\TestArchives\"
    tempPath = Environ("TEMP") & "\"
    
    For Each olkMsg In Outlook.ActiveExplorer.Selection
        ' 处理邮件主题中的非法字符
        safeSubject = Replace(Replace(Replace(olkMsg.Subject, "/", "-"), "\", "-"), ":", "-")
        tempFileName = tempPath & safeSubject & ".msg"
        
        ' 保存到临时文件
        olkMsg.SaveAs tempFileName, olMSG
        
        ' 复制到同步文件夹（覆盖已存在文件）
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        fso.CopyFile tempFileName, spSyncFolder & safeSubject & ".msg", True
        
        ' 清理临时文件
        Kill tempFileName
        MsgBox "邮件已保存到同步文件夹，将自动同步到SharePoint"
    Next olkMsg
End Sub

说明：

• 同步文件夹路径可在文件资源管理器的「OneDrive - 公司名」目录下找到对应的SP库位置。

原方法失败原因说明 #

• 直接使用HTTPS路径：Outlook的SaveAs仅支持本地路径或传统网络共享（UNC），不识别云端HTTPS路径。
• 编码URL：SaveAs会将编码后的URL当作本地文件路径处理，实际文件被保存到了本地不知名目录。
• 云端UNC路径：SharePoint Online不支持传统UNC映射，仅旧版SP服务器或特定工具映射的路径才有效。
• 临时文件转移失败：多因路径错误、权限不足，或未利用SP的同步/API上传机制导致。

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