Excel VBA如何适配多用户路径打开拆分Access数据库

原有代码问题说明 #

你之前写的代码存在3个核心错误，无法实现预期效果：

• 路径硬编码了固定用户名francisco.dias，没有做动态适配，其他用户运行时必然找不到文件
• 误用Workbooks.Open方法：该方法仅支持打开Excel格式的工作簿文件，无法打开Access编译格式的.accde数据库
• 没有对通配符匹配逻辑做遍历校验，直接传通配符路径给文件打开函数会直接触发路径不存在错误

推荐实现方案（无通配符，稳定性最高） #

不要用通配符做路径匹配——Windows系统提供了内置的特殊目录读取接口，可以直接拿到当前登录用户的Documents文件夹真实路径，自动适配不同用户名、甚至用户手动修改过文档目录存储位置的场景，完全不会出现匹配错误的问题。
完整可运行代码如下：

Sub OpenLocalAccessDB()
    Dim accApp As Object
    Dim dbPath As String
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' 直接读取当前用户的Documents目录路径，自动适配用户名
    dbPath = fso.BuildPath( _
        CreateObject("WScript.Shell").SpecialFolders("MyDocuments"), _
        "Data\Data.accde" _
    )
    
    ' 前置校验文件是否存在
    If Not fso.FileExists(dbPath) Then
        MsgBox "数据库文件不存在，检查路径：" & vbCrLf & dbPath, vbExclamation
        GoTo ClearRes
    End If
    
    ' 创建Access对象打开数据库，不要用Workbooks.Open
    Set accApp = CreateObject("Access.Application")
    accApp.Visible = True ' 设为False可后台静默打开，不显示Access窗口
    accApp.OpenCurrentDatabase Filename:=dbPath, ReadOnly:=False

    ' 此处可追加后续数据库操作逻辑

ClearRes:
    ' 释放对象，避免后台残留Access进程
    If Not accApp Is Nothing Then
        accApp.CloseCurrentDatabase
        accApp.Quit
        Set accApp = Nothing
    End If
    Set fso = Nothing
End Sub

通配符匹配方案（适配固定目录规则场景） #

如果你们办公环境强制要求所有用户的文件必须存在于C:\User\<用户名>\路径下，无法通过系统接口读取目录，可以用Dir遍历第一层子文件夹做匹配，代码如下：

Sub OpenDBWithWildcard()
    Dim accApp As Object
    Dim dbPath As String, searchFolder As String, tempName As String
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    searchFolder = "C:\User\"
    dbPath = ""
    
    ' 遍历C:\User下的所有第一层子文件夹
    tempName = Dir(searchFolder & "*", vbDirectory)
    Do While tempName <> ""
        ' 跳过系统内置的.、..目录
        If tempName <> "." And tempName <> ".." Then
            Dim testPath As String
            testPath = fso.BuildPath(searchFolder, tempName & "\Documents\Data\Data.accde")
            ' 找到匹配的文件就终止遍历
            If fso.FileExists(testPath) Then
                dbPath = testPath
                Exit Do
            End If
        End If
        tempName = Dir
    Loop
    
    If dbPath = "" Then
        MsgBox "未找到匹配的数据库文件", vbExclamation
        GoTo ClearRes
    End If
    
    ' 打开数据库逻辑和前述方案一致
    Set accApp = CreateObject("Access.Application")
    accApp.Visible = True
    accApp.OpenCurrentDatabase Filename:=dbPath, ReadOnly:=False

    ' 此处可追加后续数据库操作逻辑

ClearRes:
    If Not accApp Is Nothing Then
        accApp.CloseCurrentDatabase
        accApp.Quit
        Set accApp = Nothing
    End If
    Set fso = Nothing
End Sub

注意：通配符遍历方案的容错性更低，如果C:\User下存在多个符合路径规则的文件，会默认取第一个遍历到的结果，可能打开错误位置的文件，非必要不优先使用。

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