Scripting.FileSystemObject的CreateTextFile方法在SharePoint路径下执行失败求助

问题根源 #

FileSystemObject（FSO）是为本地文件系统和传统SMB共享设计的，直接转换SharePoint URL为简单UNC路径无法正常工作——现代SharePoint的网络访问依赖WebDAV协议，而非普通文件共享协议，你的路径转换方式不符合WebDAV的格式要求。

可行解决方案 #

1. 转换为正确的WebDAV UNC路径

SharePoint的WebDAV访问需要特定格式的UNC路径，正确转换逻辑如下：

If InStr(currPath, ".sharepoint.") > 0 Then
    ' 移除https://前缀
    currPath = Replace(currPath, "https://", "")
    ' 拆分域名和后续路径
    Dim domainEnd As Integer
    domainEnd = InStr(currPath, "/")
    Dim spDomain As String, spPath As String
    spDomain = Left(currPath, domainEnd - 1)
    spPath = Mid(currPath, domainEnd)
    ' 组合成WebDAV UNC路径
    currPath = "\\" & spDomain & "@SSL\DavWWWRoot" & Replace(spPath, "/", "\")
End If

' 创建文件
Dim fso As Object, newFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set newFile = fso.CreateTextFile(currPath & "\" & txtFileName, True) ' True表示覆盖已存在文件
newFile.Write "测试内容"
newFile.Close

2. 使用SharePoint REST API写入文件（推荐）

对于云环境的SharePoint，REST API是更可靠的方式，无需依赖路径映射：

Sub WriteToSharePointREST()
    Dim spSiteUrl As String, spFolderPath As String, fileName As String
    spSiteUrl = "https://mycompany.sharepoint.com"
    spFolderPath = "/somefolder/anotherfolder/anotherfolder"
    fileName = "test.txt"
    Dim fileContent As String
    fileContent = "这是写入SharePoint的内容"
    
    ' 生成REST请求URL
    Dim restUrl As String
    restUrl = spSiteUrl & "/_api/web/GetFolderByServerRelativeUrl('" & spFolderPath & "')/Files/add(url='" & fileName & "', overwrite=true)"
    
    ' 创建HTTP请求
    Dim xmlHttp As Object
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    xmlHttp.Open "POST", restUrl, False
    ' 添加认证头（现代SharePoint需Azure AD认证，需自行实现令牌获取逻辑）
    xmlHttp.setRequestHeader "Authorization", "Bearer " & GetSPAccessToken()
    xmlHttp.setRequestHeader "Content-Type", "text/plain"
    xmlHttp.setRequestHeader "X-RequestDigest", GetRequestDigest(spSiteUrl)
    
    ' 发送内容
    xmlHttp.Send fileContent
    
    ' 检查响应
    If xmlHttp.Status = 200 Or xmlHttp.Status = 201 Then
        MsgBox "文件写入成功"
    Else
        MsgBox "写入失败：" & xmlHttp.Status & " - " & xmlHttp.statusText
    End If
End Sub

' 辅助函数：获取请求摘要（需导入VBA-JSON库解析响应）
Function GetRequestDigest(spSiteUrl As String) As String
    Dim xmlHttp As Object
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    xmlHttp.Open "POST", spSiteUrl & "/_api/contextinfo", False
    xmlHttp.setRequestHeader "Content-Type", "application/json;odata=verbose"
    xmlHttp.Send ""
    Dim resp As Object
    Set resp = JsonConverter.ParseJson(xmlHttp.responseText)
    GetRequestDigest = resp("d")("GetContextWebInformation")("FormDigestValue")
End Function

注：需自行集成Azure AD认证库获取访问令牌，同时导入VBA-JSON模块解析响应。

3. 映射SharePoint文件夹为网络驱动器

手动或通过VBA将SharePoint文件夹映射为本地驱动器，之后可像访问本地路径一样用FSO操作：

' 映射网络驱动器
Sub MapSPDrive()
    Dim net As Object
    Set net = CreateObject("WScript.Network")
    ' 映射为Z盘，路径使用WebDAV格式
    net.MapNetworkDrive "Z:", "\\mycompany.sharepoint.com@SSL\DavWWWRoot\somefolder\anotherfolder", False
End Sub

' 使用映射路径创建文件
Set newFile = fso.CreateTextFile("Z:\" & txtFileName, True)

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