Access升级Office365：VBA文件选择对话框功能适配求助

问题 #

• 正在将Access 2010数据库升级到Office 365，原《Access 97开发者手册》中的文件选择API代码已失效
• 需要实现对话框：支持选择现有数据库文件，也允许输入新文件名；若文件已存在，显示原有名称且允许修改，操作方式由用户决定
• 已尝试Application.FileDialog(msoFileDialogFolderPicker)和Application.FileDialog(msoFileDialogFilePicker)实现文件夹/文件选择，但遇到以下问题：
  • 使用msoFileDialogSaveAs时，文件已存在会弹出提示："dbfiles.accdb already exists. Do you wish to replace it"
  • 使用msoFileDialogFilePicker无法输入新文件名

解决方案 #

方案1：使用内置FileDialog实现（简单易维护） #

通过msoFileDialogSaveAs对话框，自定义逻辑取消默认覆盖提示，同时保留选择现有文件和输入新文件名的功能：

Option Compare Database
Option Explicit

Public Function GetDatabasePath(strInitialDir As String, strInitialFile As String, strDialogTitle As String) As String
    Dim fd As FileDialog
    Dim selectedPath As String
    
    Set fd = Application.FileDialog(msoFileDialogSaveAs)
    
    With fd
        .Title = strDialogTitle
        .InitialFileName = strInitialDir & "\" & strInitialFile
        .Filter = "Access数据库 (*.accdb)|*.accdb|所有文件 (*.*)|*.*"
        .FilterIndex = 1
        .AllowMultiSelect = False
        .ButtonName = "确认"
        
        If .Show = -1 Then
            selectedPath = .SelectedItems(1)
            
            ' 可根据需求添加自定义文件存在判断逻辑
            ' 示例：
            ' If Dir(selectedPath) <> "" Then
            '     If MsgBox("文件已存在，是否覆盖？", vbYesNo) = vbNo Then
            '         GetDatabasePath = ""
            '         Exit Function
            '     End If
            ' End If
            
            GetDatabasePath = selectedPath
        Else
            GetDatabasePath = ""
        End If
    End With
    
    Set fd = Nothing
End Function

' 替换原有ExportDatabase逻辑的调用示例
Public Function ExportDatabase() As String
    Dim export_dir As String
    Dim export_file As String
    Dim DialogTitle As String
    
    If export_file = "" Then export_dir = "C:\"
    DialogTitle = "定位并选择数据库"
    
    export_file = GetDatabasePath(export_dir, export_file, DialogTitle)
    
    If export_file <> "" Then
        ' 保留原有的目录与文件名分离逻辑
        Dim exportfiletemp As String
        exportfiletemp = export_file
        export_dir = ""
        Do Until InStr(exportfiletemp, "\") = 0
            export_dir = export_dir & Left$(exportfiletemp, InStr(exportfiletemp, "\"))
            exportfiletemp = Mid$(exportfiletemp, InStr(exportfiletemp, "\") + 1)
        Loop
        ' 可根据需求更新export_dir和export_file变量
    End If
    
    ExportDatabase = export_file
End Function

方案2：适配64位的API实现（贴近原有代码逻辑） #

保留原API调用方式，适配Office 365的64位环境，通过设置标志实现“选择现有文件/输入新文件”的功能：

Option Compare Database
Option Explicit

#If VBA7 Then
    Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
#Else
    Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
#End If

Type OPENFILENAME
    lStructSize As Long
    hwndOwner As LongPtr
    hInstance As LongPtr
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As LongPtr
    lpfnHook As LongPtr
    lpTemplateName As String
End Type

' 标志常量
Const OFN_CREATEPROMPT = &H2000    ' 文件不存在时提示创建
Const OFN_OVERWRITEPROMPT = &H2     ' 文件存在时提示覆盖（不需要可移除）
Const OFN_HIDEREADONLY = &H4        ' 隐藏只读选项
Const OFN_PATHMUSTEXIST = &H800     ' 路径必须存在
Const OFN_EXPLORER = &H80000        ' 使用资源管理器风格对话框

Function FindLinkedDatabase(strSearchPath As String, DialogTitle As String, LinkedDb As String) As String
    Dim ofn As OPENFILENAME
    Dim retVal As Boolean
    Dim filePath As String
    
    ' 初始化OPENFILENAME结构
    With ofn
        .lStructSize = Len(ofn)
        .hwndOwner = Application.hWndAccessApp
        .lpstrFilter = "Access数据库 (*.accdb)" & vbNullChar & "*.accdb" & vbNullChar & "所有文件 (*.*)" & vbNullChar & "*.*" & vbNullChar
        .nFilterIndex = 1
        .lpstrFile = LinkedDb & String(256 - Len(LinkedDb), vbNullChar)
        .nMaxFile = 255
        .lpstrFileTitle = String(256, vbNullChar)
        .nMaxFileTitle = 255
        .lpstrInitialDir = strSearchPath
        .lpstrTitle = DialogTitle
        ' 组合标志实现需求，不需要覆盖提示则移除OFN_OVERWRITEPROMPT
        .Flags = OFN_CREATEPROMPT Or OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST Or OFN_EXPLORER
        .lpstrDefExt = "accdb"
    End With
    
    retVal = GetSaveFileName(ofn)
    
    If retVal Then
        ' 提取有效文件路径
        filePath = Left(ofn.lpstrFile, InStr(ofn.lpstrFile, vbNullChar) - 1)
        FindLinkedDatabase = filePath
    Else
        FindLinkedDatabase = ""
    End If
End Function

' 替换原有ExportDatabase逻辑的调用示例
Public Function ExportDatabase() As String
    Dim export_dir As String
    Dim export_file As String
    Dim DialogTitle As String
    
    If export_file = "" Then export_dir = "C:\"
    DialogTitle = "定位并选择数据库"
    
    export_file = FindLinkedDatabase(export_dir, DialogTitle, export_file)
    
    If export_file <> "" Then
        ' 保留原有的目录与文件名分离逻辑
        Dim exportfiletemp As String
        exportfiletemp = export_file
        export_dir = ""
        Do Until InStr(exportfiletemp, "\") = 0
            export_dir = export_dir & Left$(exportfiletemp, InStr(exportfiletemp, "\"))
            exportfiletemp = Mid$(exportfiletemp, InStr(exportfiletemp, "\") + 1)
        Loop
        ' 可根据需求更新export_dir和export_file变量
    End If
    
    ExportDatabase = export_file
End Function

代码说明 #

• 方案1使用Access内置对话框，无需API调用，适配Office 365环境，维护成本低
• 方案2保留原API逻辑，适配64位Access，通过OFN_CREATEPROMPT标志允许输入新文件名，同时支持选择现有文件；若不需要默认覆盖提示，可移除OFN_OVERWRITEPROMPT标志
• 两种方案均保留了原有代码中分离目录和文件名的逻辑，确保与原有功能兼容

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