使用代码另存当前打开的ACCESS数据库文件

项目场景：

以前每次更新ACCESS数据库文件后，需要拷贝粘贴更新后的文件到各个备份存储文件夹内，很繁琐，而且还容易有遗漏。

问题描述

使用FSO的File的Copy方法，运行代码不报错，但是不能实现打开的当前数据库文件另存。

Set objFso = CreateObject(“Scripting.FileSystemObject”) '创建FSO对象实例
If objFso.FileExists(strPath & strName) Then
Set objFile = objFso.GetFile(strPath & strName)
objFile.Copy strPath_Des & strNewName '用这种方法无法复制打开的文件，即当前打开的文件无法用这种方法复制
End If

原因分析：

使用FSO的File的Copy方法是不能处理打开着的文件的。

解决方案：

Private Sub CmdSaveVsMdf_Click()
On Error GoTo Err_CmdSaveVsMdf
Dim objFso As Object
Dim objFile As Object
Dim strPath As String
Dim strName As String
Dim strPath_Des1, strPath_Des2, strPath_Des3 As String
Dim strOldName, strNewName As String
Dim strLastDate As String
strLastDate = DLookup(“修改日期”, “F_数据库设置”, “[引索]=‘1’”)
If IsNull(Me.TxtNewVersion) Then
Me.TxtNewVersion.SetFocus
Exit Sub
End If
If IsNull(Me.TxtNewDate) Then
Me.TxtNewDate.SetFocus
Exit Sub
End If
If MsgBox(“版本修订日期的格式为YYYYMMDD（例如20230807）吗？”, vbYesNo + vbQuestion, “请确认信息…”) = vbYes Then
DoCmd.SetWarnings False
DoCmd.RunSQL “update K_服务器设置 set 版本号='” & Me.TxtNewVersion & “’ where 引索=‘1’”
DoCmd.RunSQL “update K_服务器设置 set 修改日期=” & Me.TxtNewDate & " where 引索=‘1’"
DoCmd.RunSQL “update F_数据库设置 set 版本号='” & Me.TxtNewVersion & “’ where 引索=‘1’”
DoCmd.RunSQL “update F_数据库设置 set 修改日期=” & Me.TxtNewDate & " where 引索=‘1’"
DoCmd.SetWarnings True
MsgBox “新版本设定成功！”
Else
Me.TxtNewDate.SetFocus
Exit Sub
End If

strPath = CurrentProject.Path & "\"
strName = CurrentProject.Name
strOldName = "维修管理系统_off64" & strLastDate & "版.accdb"       '旧版本的名字
strNewName = "维修管理系统_off64" & Me.TxtNewDate & "版.accdb"     '新版本的名字
'另存新版本的数据库文件
strPath_Des1 = DLookup("更新版本备份地址1", "F_数据库设置", "[引索]='1'")    '存盘位置1
strPath_Des2 = DLookup("更新版本备份地址2", "F_数据库设置", "[引索]='1'")    '存盘位置2
strPath_Des3 = DLookup("更新版本备份地址3", "F_数据库设置", "[引索]='1'")    '数据库发布的地址
Set objFso = CreateObject("Scripting.FileSystemObject")                      '创建FSO对象实例
'If objFso.FileExists(strPath & strName) Then
    'Set objFile = objFso.GetFile(strPath & strName)
    'objFile.Copy strPath_Des & strNewName           
'End If
objFso.CopyFile strPath & strName, strPath_Des1 & strNewName                 '实施另存
objFso.CopyFile strPath & strName, strPath_Des2 & strNewName
objFso.CopyFile strPath & strName, strPath_Des3 & strNewName
'删除数据库发布地址里的旧版本文件
If objFso.FileExists(strPath_Des3 & strOldName) Then
    Set objFile = objFso.GetFile(strPath_Des3 & strOldName)
    objFile.Delete True
End If
MsgBox "新版本另存完成，请核对发布地址内的数据库文件是否已经删除旧版并存盘了新版！", vbInformation, "提醒........."
Set objFile = Nothing
Set objFso = Nothing

Exit_CmdSaveVsMdf:
Exit Sub
Err_CmdSaveVsMdf:
MsgBox Err.Description
Resume Exit_CmdSaveVsMdf
End Sub