Access 2007 Make ACCDE from VBA SysCmd 603

Question

我正在尝试自动执行我通常会执行的任务，以压缩我的数据库，保存备份，并为我正在使用的自动更新系统更新修订号。我一直在尝试用vba脚本制作一个accde文件。

我发现的所有与这个主题有关的东西似乎都指向使用这样的东西。

function MakeACCDE(InPath As String, OutPath As String)
Dim app As New Access.Application
app.AutomationSecurity = msoAutomationSecurityLow
app.SysCmd 603, InPath, OutPath
End Function

各种论坛上的一些用户声称这段代码对他们有效，但我运气不佳。我的数据库运行代码时没有出现错误，但实际上什么也没发生。

是否有我没有使用的特定语法，或者文件路径的格式有什么问题？

Answer 1

我在找到了以下代码：http://www.experts-exchange.com/questions/28429044/How-do-I-create-an-Access-2010-accde-from-VBA.html

我插入我的Access 2010 accdb，运行它，它创建了一个accde

**更新：看到你想从另一个数据库运行，我也测试了。。。只需将行"tmpDB_Full_Name=CurrentProject.FullName"更改为源数据库

Option Compare Database
Option Explicit
Function Create_MDE()
 Dim tmpDB_Full_Name As String
    Dim tmpDB_Name As String
    Dim tmpDB_Backup_Full_Name As String
    Dim tmpCopy_File As Variant
    Dim tmpDirectory As String
    'Call SetStartupOptions("AllowBypassKey", dbBoolean, False)               '---This runs a procedure to deactivate the Shift & F11 key
    'tmpDB_Full_Name = CurrentProject.FullName
    tmpDB_Full_Name = "C:dataaccessMyDb.accdb"
    tmpDirectory = CurrentProject.Path
    tmpDB_Name = CurrentProject.Name
    tmpDB_Backup_Full_Name = tmpDirectory & "" & left(tmpDB_Name, Len(tmpDB_Name) - 6) & "-Backup.accdb"
    'this removes a file created on the same day
    If Dir(tmpDB_Backup_Full_Name) <> "" Then
        Kill tmpDB_Backup_Full_Name
    End If
    'this creates a backup into destination tmpDirectory
    If Dir(tmpDB_Backup_Full_Name) = "" Then
        Set tmpCopy_File = CreateObject("Scripting.FileSystemObject")
        tmpCopy_File.CopyFile tmpDB_Full_Name, tmpDB_Backup_Full_Name, True
    End If
    Dim app As New Access.Application
    app.AutomationSecurity = msoAutomationSecurityLow
    app.SysCmd 603, tmpDB_Backup_Full_Name, tmpDirectory & "" & left(tmpDB_Name, Len(tmpDB_Name) - 9) & ".accde"
    'Call SetStartupOptions("AllowBypassKey", dbBoolean, True)                 '---This runs a procedure to activate the Shift & F11
    MsgBox ("Compile Complete!")
End Function

Answer 2

我准备了一个现成的解决方案，它可以创建一个ACCDE文件，同时允许您使用密码保护它。通过频繁的更新，它让我的生活变得轻松多了。我在Microsoft Access 2016和2019上测试了它。

函数SaveAccdbAsAccde()执行以下步骤：

• 编译并保存对数据库的更改
• 将数据库复制到"…"。。。（~temp~）.ACDB'
• 创建文件"。。。（~temp~）.ACDE'
• 如果一切正常，它会为数据库设置一个密码，并将其复制为目标文件
• 删除工作文件

要使用密码保护数据库，请执行以下操作：SaveAccdbAsAccde("password")

我使用了一些功能，这些功能可能也适用于其他任务：

• 基于Scripting.FileSystemObject用于处理文件的助手函数使用：CopyFile()、DeleteFile()和FileExists()
• 使用密码EncryptDb()和DecryptDb()保护/取消保护数据库的功能

以下所有详细信息：

Option Explicit
'------------------------------------------------------------------------------------
'main function
Public Sub SaveAccdbAsAccde(Optional filePassword As String)
On Error Resume Next
    Application.RunCommand acCmdCompileAndSaveAllModules
    err.Clear
    If err <> 0 Then MsgBox "Save changes in forms and reports before preparing the ACCDE file.": Exit Sub
On Error GoTo err_proc
    Dim strFile0 As String, strFile1 As String, strFile2 As String, strFile3 As String
    strFile0 = CurrentDb.Name
    strFile1 = Replace(CurrentDb.Name, ".accdb", "(~temp~).accdb")
    strFile2 = Replace(CurrentDb.Name, ".accdb", "(~temp~).accde")
    strFile3 = Replace(CurrentDb.Name, ".accdb", ".accde")
    If Not DeleteFile(strFile1) Then MsgBox "Can't felete file: " & strFile2: Exit Sub
    If Not CopyFile(strFile0, strFile1) Then MsgBox "Can't copy file: " & strFile0 & " na " & strFile1: Exit Sub
    
    If Not DeleteFile(strFile2) Then MsgBox "Can't delete file: " & strFile2: Exit Sub
    MakeACCDESysCmd strFile1, strFile2
    If Not FileExists(strFile2) Then MsgBox "Can't create file: " & strFile2: Exit Sub
    
    If Not DeleteFile(strFile3) Then MsgBox "Can't delete file: " & strFile3: Exit Sub
    EncryptDb strFile2, strFile3, filePassword
    If Not FileExists(strFile3) Then MsgBox "Can't create file: " & strFile3: Exit Sub
    
    If Not DeleteFile(strFile2) Then MsgBox "Can't delete file: " & strFile2: Exit Sub
    If Not DeleteFile(strFile1) Then MsgBox "Can't delete file: " & strFile2: Exit Sub
MsgBox "Done: " & strFile3
exit_proc:
    Exit Sub
    
err_proc:
    MsgBox err.Description, vbCritical, "Error"
    Resume exit_proc
End Sub
'------------------------------------------------------------------------------------
Public Sub EncryptDb(strSourcePath As String, strDestPath As String, pwd As String)
    If pwd <> "" Then pwd = ";pwd=" & pwd
    DBEngine.CompactDatabase strSourcePath, strDestPath, dbLangGeneral & pwd, dbVersion167, pwd
End Sub
Public Sub DecryptDb(strSourcePath As String, strDestPath As String, pwd As String)
    If pwd <> "" Then pwd = ";pwd=" & pwd
    DBEngine.CompactDatabase strSourcePath, strDestPath, dbLangGeneral & ";pwd=", dbVersion167, pwd
End Sub
Public Function MakeACCDESysCmd(InPath As String, OutPath As String)
    Dim app As Access.Application
    Set app = New Access.Application
    app.AutomationSecurity = 1 'msoAutomationSecurityLow - Enables all macros. This is the default value when the application is started.
    app.SysCmd 603, InPath, OutPath 'an undocumented action
    app.Quit acQuitSaveNone
    Set app = Nothing
End Function
'------------------------------------------------------------------------------------
Public Function CopyFile(strFromFile, strToFile)
On Error Resume Next
    Dim objFSO
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    err.Clear
    objFSO.CopyFile strFromFile, strToFile, True
    CopyFile = err = 0
    Set objFSO = Nothing
End Function
Public Function DeleteFile(strFile)
    If Not FileExists(strFile) Then DeleteFile = True: Exit Function
On Error Resume Next
    Dim objFSO
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    err.Clear
    objFSO.DeleteFile strFile, True
    DeleteFile = err = 0
    Set objFSO = Nothing
End Function
Public Function FileExists(strFile)
On Error Resume Next
    Dim objFSO
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    FileExists = objFSO.FileExists(strFile)
    Set objFSO = Nothing
End Function

Answer 3

我在Access 2016中使用ACCDE和ACCDR作为目标文件扩展名测试了以下代码：

        Dim otherAccess As Access.Application
        Set otherAccess = New Access.Application
        otherAccess.AutomationSecurity = 1 'msoAutomationSecurityLow
        otherAccess.SysCmd 603, InPath, OutPath
        otherAccess.Quit acQuitSaveNone
        Set otherAccess = Nothing