请教

Question

我做的图书馆里系统，数据备份的时候，只能保存在默认的一个文件夹下，我想让它弹出一个对话框保存在任意目录下，请高手给我改一下
Dim olddb As String
  Dim Fs As FileSystemObject
  Dim BackUpFile As String
  olddb = App.Path + "\" + DBName
  BackUpFile = App.Path + "\数据库备份\" + "_" + DBName
  If MsgBox("你确定要备份当前数据库吗？", vbQuestion + vbOKCancel _
                + vbDefaultButton2, "请确认") = vbCancel Then
    Exit Sub
  End If
  Set Fs = CreateObject("Scripting.FileSystemObject")
  '拷贝数据库文件至指定位置
  Fs.CopyFile olddb, BackUpFile
  MsgBox "数据库备份成功", vbInformation + vbOKOnly, "信息"

Answer 1

Private Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As LongPrivate Function SelectDirectory(Byval sTitle As String) As String
    Dim iNull As Integer, lpIDList As Long, lResult As Long
    Dim sPath As String, udtBI As BrowseInfo
    With udtBI
        .hWndOwner = Me.hWnd
        .lpszTitle = lstrcat(sTitle, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        SHGetPathFromIDList lpIDList, sPath
        CoTaskMemFree lpIDList
        iNull = InStr(sPath, vbNullChar)
        If iNull Then sPath = Left(sPath, iNull - 1)
    End If
    SelectDirectory = sPath
End Function
......
  Dim olddb As String
  Dim Fs As FileSystemObject
  Dim BackUpFile As String
  Dim sPath As String
  sPath = SelectDirectory("请选择数据库备份保存的文件夹")
  If sPath <> "" Then
    olddb = App.Path + "\" + DBName
    BackUpFile = sPath + "数据库备份\" + "_" + DBName
    If MsgBox("你确定要备份当前数据库吗？", vbQuestion + vbOKCancel _
                + vbDefaultButton2, "请确认") = vbCancel Then
      Exit Sub
    End If
    Set Fs = CreateObject("Scripting.FileSystemObject")
    '拷贝数据库文件至指定位置
    Fs.CopyFile olddb, BackUpFile
    MsgBox "数据库备份成功", vbInformation + vbOKOnly, "信息"
  End If

Answer 2

用COMMONDIALOG通用对话框的showsave方法来得到一个完整的路径和文件名，然后剥离出路径来就可以了，挺简单的代码， 不写了