Access窗体打开事件复制后端文件遇权限错误，求解决方案

问题描述 #

我在Access窗体的Form_Open事件中编写代码，试图将后端数据库文件复制到指定的Backups文件夹，但执行时出现权限错误。手动复制粘贴文件到该文件夹可正常操作，以下是我的VBA代码，求排查操作错误或绕过权限问题的方法：

Private Sub Form_Open()
Dim fso As Object
Dim connectionStr As String
Dim filePath As String
Dim fileName As String
Dim BackUpFolder As String

Set fso = CreateObject("Scripting.FileSystemObject")

connectionStr = CurrentDb.TableDefs("tblAllRecords").Connect
filePath = Mid(Left(connectionStr, InStrRev(connectionStr, "\")), InStrRev(connectionStr, "=") + 1)
BackUpFolder = Mid(Left(connectionStr, InStrRev(connectionStr, "\")), InStrRev(connectionStr, "=") + 1) & "Backups"

If InStr(connectionStr, "DATABASE=") > 0 Then
    filePath = Replace(Mid(connectionStr, InStr(connectionStr, "DATABASE=") + Len("DATABASE=")), ";", "")
    fileName = Dir(filePath)
Else
    ' Handle the case where "DATABASE=" is not found
    MsgBox "The connection string is broken. Contact your database Administrator.", vbExclamation
    Exit Sub
End If

' Check if the backup folder exists, and create it if necessary
If Len(Dir(BackUpFolder, vbDirectory)) = 0 Then
    MkDir BackUpFolder
End If

' Ensure full paths are provided
filePath = fso.BuildPath(fso.GetParentFolderName(filePath), fileName)
BackUpFolder = fso.BuildPath(fso.GetParentFolderName(BackUpFolder), fso.GetFileName(BackUpFolder))


'fso.CopyFile filePath, BackUpFolder
FileCopy filePath, BackUpFolder

If Err.Number <> 0 Then
    MsgBox "Error copying file: " & Err.Description, vbExclamation
Else
    MsgBox "File copied successfully!", vbInformation
End If

Exit Sub


End Sub

代码问题排查 #

• 路径逻辑错误：初始拼接BackUpFolder后，又用fso.BuildPath二次处理，导致备份路径被错误修改为后端目录的上级目录下的Backups，而非预期的后端目录子文件夹，路径异常可能触发权限判断问题。
• 文件锁定问题：Access连接后端数据库时会锁定文件，此时直接用FileCopy或FSO复制会因文件被占用触发权限/锁定错误，这是最常见的原因。
• 冗余路径处理：先对filePath错误赋值，后又在分支中重新赋值，冗余代码易引发路径混乱。

修正方案与权限绕过方法 #

方案1：修正路径+临时断开后端连接 #

通过临时断开后端连接解除文件锁定，同时修正路径逻辑：

Private Sub Form_Open(Cancel As Integer)
    Dim fso As Object
    Dim connectionStr As String
    Dim backendPath As String
    Dim backupFolder As String
    Dim backupPath As String
    Dim tblDef As TableDef
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 正确获取后端数据库路径
    Set tblDef = CurrentDb.TableDefs("tblAllRecords")
    connectionStr = tblDef.Connect
    If InStr(connectionStr, "DATABASE=") = 0 Then
        MsgBox "连接字符串异常，请联系管理员。", vbExclamation
        Cancel = True
        Exit Sub
    End If
    backendPath = Replace(Mid(connectionStr, InStr(connectionStr, "DATABASE=") + Len("DATABASE=")), ";", "")
    
    ' 构建备份文件夹路径（后端文件所在目录下的Backups）
    backupFolder = fso.BuildPath(fso.GetParentFolderName(backendPath), "Backups")
    ' 创建备份文件夹（如果不存在）
    If Not fso.FolderExists(backupFolder) Then
        fso.CreateFolder backupFolder
    End If
    
    ' 构建带时间戳的备份文件路径，避免覆盖
    backupPath = fso.BuildPath(backupFolder, _
        fso.GetBaseName(backendPath) & "_" & Format(Now(), "yyyyMMdd_HHmmss") & "." & fso.GetExtensionName(backendPath))
    
    On Error GoTo ErrorHandler
    ' 临时断开后端连接
    tblDef.Connect = ""
    tblDef.RefreshLink
    ' 复制文件
    FileCopy backendPath, backupPath
    ' 重新连接后端
    tblDef.Connect = connectionStr
    tblDef.RefreshLink
    
    MsgBox "备份成功！", vbInformation
    Exit Sub
    
ErrorHandler:
    ' 出错时确保重新连接后端
    tblDef.Connect = connectionStr
    tblDef.RefreshLink
    MsgBox "备份失败：" & Err.Description, vbExclamation
    Cancel = True
End Sub

方案2：用Shell命令绕过文件锁定 #

通过Windowsxcopy命令在外部进程执行复制，绕开Access的文件锁定：

' 替换原代码中的复制逻辑部分
Dim shellCmd As String
shellCmd = "xcopy """ & backendPath & """ """ & backupFolder & """ /Y"
Shell shellCmd, vbHide
MsgBox "备份命令已执行，请检查Backups文件夹。", vbInformation

方案3：权限与运行方式检查 #

• 确保Access以管理员身份运行，部分系统目录（如Program Files）需要管理员权限才能写入。
• 检查Backups文件夹的NTFS权限，确认当前用户拥有写入权限（手动复制正常不代表程序上下文权限一致）。

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