I am upgrading a database from Access 2010 to Office 365. The issue is that the code from the Access 97 Developer's Handbook by Litwin, Getz, and Gilbert (Sybex) Copyright 1997, which has been used since the database was first developed in Access 97 to obtain file and folder information, no longer works.
A little additional context: I retired from coding at least six years ago, so I am somewhat rusty and not up to date. However, I have been asked to upgrade the database as I am the only one who knows anything about how it operates from the code side. My problem is that I need to recode so that a user can either select an existing database file or name a new one with one dialog box, as it used to work in Access 2010 and prior versions. If the file was previously created by the database, this name should appear in the dialog box, but the user should be able to overwrite it with a new name. In other words, the decision is the user's, not the coder's.
I have managed to recode the folder locator and file find sections using Application.FileDialog(msoFileDialogFolderPicker) and Application.FileDialog(msoFileDialogFilePicker).
When I try to either name a new file or select an existing one with the same dialog box:
I have tried to use Application.FileDialog(msoFileDialogSaveAs), but if the file already exists this throws up the following: "dbfiles.accdb already exists. Do you wish to replace it".
If I use Application.FileDialog(msoFileDialogFilePicker) I cannot name a new file.
Option Compare Database
Option Explicit ' Require variables to be declared before being used.
Option Compare Database ' Use database order for string comparisons.
Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Type MSA_OPENFILENAME
' Filter string used for the Open dialog filters.
' Use MSA_CreateFilterString() to create this.
' Default = All Files, *.*
strFilter As String
' Initial Filter to display.
' Default = 1.
lngFilterIndex As Long
' Initial directory for the dialog to open in.
' Default = Current working directory.
strInitialDir As String
' Initial file name to populate the dialog with.
' Default = "".
strInitialFile As String
strDialogTitle As String
' Default extension to append to file if user didn't specify one.
' Default = System Values (Open File, Save File).
strDefaultExtension As String
' Flags (see constant list) to be used.
' Default = no flags.
lngFlags As Long
' Full path of file picked. When the File Open dialog box is
' presented, if the user picks a nonexistent file,
' only the text in the "File Name" box is returned.
strFullPathReturned As String
' File name of file picked.
strFileNameReturned As String
' Offset in full path (strFullPathReturned) where the file name
' (strFileNameReturned) begins.
intFileOffset As Integer
' Offset in full path (strFullPathReturned) where the file extension begins.
intFileExtension As Integer
End Type
Const ALLFILES = "All Files"
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As Long
nMaxCustrFilter 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
lCustrData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10
Public Function ExportDatabase()
Dim exportfiletemp As String
Dim DialogTitle As String, AppTitle As String
If export_file = "" Then export_dir = "C:\"
DialogTitle = "Locate and Select Database"
AppTitle = "Database Title"
export_file = FindLinkedDatabase(export_dir, DialogTitle, export_file)
ExportDatabase = export_file
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_file = exportfiletemp
End Function
Function FindLinkedDatabase(strSearchPath, DialogTitle As String, LinkedDb As String) As String
' Displays the Open dialog box for the user to locate
' the required database. Returns the full path to required database.
Dim msaof As MSA_OPENFILENAME
' Set options for the dialog box.
msaof.strDialogTitle = DialogTitle
msaof.strInitialDir = strSearchPath
msaof.strFilter = MSA_CreateFilterString("Databases", "*.accdb")
msaof.strInitialFile = LinkedDb
' Call the Open dialog routine.
MSA_GetOpenFileName msaof
' Return the path and file name.
FindLinkedDatabase = Trim(msaof.strFullPathReturned)
End Function
Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
' Creates a filter string from the passed in arguments.
' Returns "" if no argumentss are passed in.
' Expects an even number of argumentss (filter name, extension), but
' if an odd number is passed in, it appends "*.*".
Dim strFilter As String
Dim intRet As Integer
Dim intNum As Integer
intNum = UBound(varFilt)
If (intNum <> -1) Then
For intRet = 0 To intNum
strFilter = strFilter & varFilt(intRet) & vbNullChar
Next
If intNum Mod 2 = 0 Then
strFilter = strFilter & "*.*" & vbNullChar
End If
strFilter = strFilter & vbNullChar
Else
strFilter = ""
End If
MSA_CreateFilterString = strFilter
End Function
Private Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the Open dialog.
Dim of As OPENFILENAME
Dim intRet As Integer
MSAOF_to_OF msaof, of
intRet = GetOpenFileName(of)
If intRet Then
OF_to_MSAOF of, msaof
End If
MSA_GetOpenFileName = intRet
End Function
Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
' This sub converts from the Microsoft Access structure to the Win32 structure.
Dim strfile As String * 512
' Initialize some parts of the structure.
of.hwndOwner = Application.hWndAccessApp
of.hInstance = 0
of.lpstrCustomFilter = 0
of.nMaxCustrFilter = 0
of.lpfnHook = 0
of.lpTemplateName = 0
of.lCustrData = 0
If msaof.strFilter = "" Then
of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
Else
of.lpstrFilter = msaof.strFilter
End If
of.nFilterIndex = msaof.lngFilterIndex
of.lpstrFile = msaof.strInitialFile _
& String(512 - Len(msaof.strInitialFile), 0)
of.nMaxFile = 511
of.lpstrFileTitle = String(512, 0)
of.nMaxFileTitle = 511
of.lpstrTitle = msaof.strDialogTitle
of.lpstrInitialDir = msaof.strInitialDir
of.lpstrDefExt = msaof.strDefaultExtension
of.Flags = msaof.lngFlags
of.lStructSize = Len(of)
End Sub
Seems to me, the prompt to overwrite a existing file is a good idea, is it not?
Other the this minor issue, then I would consider adopting the new file dialog.
You can use that 30 year old windows API - (but, ask what other software your company is using that is 30 years old? hum???). The issue is NOT using office 365, but that of using x64 bits vs x32 bits.
So, there is a x64 bit version of that API, but as you can see, it is a rather old approach, and I would consider accepting that "minor" nag prompt when a user chooses to overwrite a existing file - really not the end of the world.
However, there is a x64 bit version of that code here:
https://gpgonaccess.blogspot.com/2010/03/work-in-progress-and-64-bit-vba.html