SharePoint路径下VBA Dir函数报错及文件存在检测失效求助

问题背景 #

• 开发UserForm供团队选择3种报告类型：Condizione di Pericolo / Mancato Infortunio / Infortunio，选择结果存储在evento变量中
• 需求：根据报告类型将报告副本保存至SharePoint同名文件夹，文件名按「日期_用户名」规则生成；若同一用户单日多次生成同类型报告，需添加(1)类后缀避免文件覆盖
• 故障现象：
  • 使用Dir命令时触发「Run-time error '52': Bad file name or number」错误
  • 使用FileExist函数时始终返回False，导致误判文件不存在而覆盖原有文件

原代码 #

保存逻辑代码 #

Sub SaveReport()

    Const path As String = "https://SharePointPath/Main%20Folder/"
    Dim i As Long
    Dim Saved As Boolean
    
    i = 1
    Saved = False
    evento = "Condizione di Pericolo"   ' Just to test the code

    Sheets("Modulo19").Activate         ' Redondant, now I know!
    ActiveSheet.Copy
    
    If evento = "Condizione di Pericolo" Then
        ' filename = path + nome del file + estensione
        filename = path & "/" & "Condizione%20di%20Pericolo" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & ".xlsx"
        
        ' Check to see if the file exist
        If Len(Dir(filename)) = "" Then
            ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
            Call GeneraReport
            Exit Sub
        Else
        End If
        
        ' If it exist, let's use another name
        Do While Saved = False
            If Len(Dir(filename)) <> "" Then
                filename = path & "/" & "Condizione%20di%20Pericolo" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & "_(&" & i & ")" & ".xlsx"
                ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
                Saved = True
                Call GeneraReport
            Else
                i = i + 1
            End If
        Loop
        

    ' From now on is just the same code repeating...

    ElseIf evento = "Mancato Infortunio" Then
        filename = path & "/" & "Mancato%20Infortunio" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & ".xlsx"
        
        If FileExist(filename) = False Then
            ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
            Call GeneraReport
            Exit Sub
        Else
        End If
        
        Do While Saved = False
            If FileExist(filename) = False Then
                filename = path & "/" & "Mancato%20Infortunio" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & "_(&" & i & ")" & ".xlsx"
                ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
                Saved = True
                Call GeneraReport
            Else
                i = i + 1
            End If
        Loop

        
    ElseIf evento = "Infortunio" Then
        filename = path & "/" & "Infortunio" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & ".xlsx"
        
        If FileExist(filename) = False Then
            ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
            Call GeneraReport
            Exit Sub
        Else
        End If
        
        Do While Saved = False
            If FileExist(filename) = False Then
                filename = path & "/" & "Infortunio" & "/" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & "_(&" & i & ")" & ".xlsx"
                ActiveWorkbook.SaveAs filename, FileFormat:=xlOpenXMLWorkbook
                Saved = True
                Call GeneraReport
            Else
                i = i + 1
            End If
        Loop
      
    End If
    
End Sub

文件检测函数 #

Function FileExist(FilePath As String) As Boolean
'PURPOSE: Test to see if a file exists or not

Dim TestStr As String

'Test File Path (ie "C:\Users\Chris\Desktop\Test\book1.xlsm")
  On Error Resume Next
    TestStr = Dir(FilePath)
  On Error GoTo 0

'Determine if File exists
  If TestStr = "" Then
    FileExist = False
  Else
    FileExist = True
  End If

End Function

解决方案 #

1. 核心故障原因 #

VBA的Dir函数仅支持本地文件系统或映射的网络驱动器路径，无法直接识别SharePoint的HTTPS远程路径；而SaveAs能生效是因为Excel原生支持直接保存到SharePoint，但文件检测API不具备该能力。

2. 可行修复方案 #

方案一：映射SharePoint文件夹为网络驱动器（推荐）

• 将SharePoint主文件夹映射为本地驱动器（如Z:\），修改路径常量为映射后的本地路径：

  Const path As String = "Z:\Main Folder\"
  

• 移除文件名中的URL编码（将%20替换为空格），遵循本地路径规则：

  filename = path & "Condizione di Pericolo\" & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & ".xlsx"
  

• 原FileExist函数可正常工作，无需修改。

方案二：编写适配SharePoint的文件检测函数（无需映射）

通过尝试以只读方式打开文件来判断是否存在，替代Dir函数：

Function SharePointFileExists(filePath As String) As Boolean
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks.Open(filePath, ReadOnly:=True)
    On Error GoTo 0
    If Not wb Is Nothing Then
        SharePointFileExists = True
        wb.Close SaveChanges:=False
    Else
        SharePointFileExists = False
    End If
End Function

• 将原代码中所有FileExist调用替换为SharePointFileExists即可。

3. 代码优化建议 #

• 移除重复逻辑：将文件名生成、文件检测封装为独立子过程，避免三个分支重复编写相同代码
• 修正重命名格式：原代码中_(&" & i & ")"是错误写法，应改为_(" & i & ")"，生成文件名(1).xlsx格式
• 避免使用Activate/ActiveSheet，直接操作目标工作表：

  Sheets("Modulo19").Copy
  

优化后完整代码示例 #

Sub SaveReport()
    Const basePath As String = "Z:\Main Folder\" ' 替换为映射路径或SharePoint HTTPS路径
    Dim evento As String
    Dim targetFolder As String
    Dim baseFilename As String
    Dim fullFilename As String
    Dim i As Long
    
    evento = "Condizione di Pericolo" ' 测试用，实际从UserForm获取
    i = 1
    
    ' 确定目标文件夹
    Select Case evento
        Case "Condizione di Pericolo"
            targetFolder = basePath & "Condizione di Pericolo\"
        Case "Mancato Infortunio"
            targetFolder = basePath & "Mancato Infortunio\"
        Case "Infortunio"
            targetFolder = basePath & "Infortunio\"
        Case Else
            MsgBox "无效的报告类型", vbExclamation
            Exit Sub
    End Select
    
    ' 生成基础文件名
    baseFilename = Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & ".xlsx"
    fullFilename = targetFolder & baseFilename
    
    ' 检测文件是否存在，生成可用文件名
    Do While SharePointFileExists(fullFilename) ' 映射路径时可替换为FileExist(fullFilename)
        fullFilename = targetFolder & Format(Now(), "dd-mm-yyyy") & "_" & Split(Application.UserName, " ")(1) & "(" & i & ").xlsx"
        i = i + 1
    Loop
    
    ' 保存文件
    Sheets("Modulo19").Copy
    ActiveWorkbook.SaveAs fullFilename, FileFormat:=xlOpenXMLWorkbook
    Call GeneraReport
    ActiveWorkbook.Close SaveChanges:=False
End Sub

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