Update File Dialog Code to work with 32-bit AND 64-bit Project 2019

Question

I've updated my version of Microsoft Project 2019 from the 32-bit version to the 64-bit version. The code below does not open the File Dialog form like it used to.

(NOTE: This is not my code. It was already part of a code set that I am now responsible for maintaining it.)

What changes do I need to make so that this code works with 32-bit and 64-bit versions of Microsoft Project 2019?

'*** BEGIN CODE ***
Type tagOPENFILENAME
    lStructSize As Long
    hwndOwner As LongPtr
    hInstance As LongPtr
    strFilter As String
    strCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    strFile As String
    nMaxFile As Long
    strFileTitle As String
    nMaxFileTitle As Long
    strInitialDir As String
    strTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    strDefExt As String
    lCustData As LongPtr
    lpfnHook As LongPtr
    lpTemplateName As String
End Type

#If VBA7 Then
    Declare PtrSafe Function aht_apiGetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
#Else
    Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
#End If

#If VBA7 Then
    Declare PtrSafe Function aht_apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
#Else
    Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
#End If

#If VBA7 Then
    Declare PtrSafe Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
#Else
    Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
#End If

#If VBA7 Then
    Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenFileName As OPENFILENAME) As Boolean
#Else
    Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenFileName As OPENFILENAME) As Boolean
#End If

#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Public Type OPENFILENAME
    lStructSize         As Long
    hwndOwner           As Long
    hInstance           As Long
    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 Long
    lpfnHook            As Long
    lpTemplateName      As String
End Type

#If VBA7 Then
    Public Declare PtrSafe Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
#Else
    Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
#End If

Global Const ahtOFN_READONLY = &H1
Global Const ahtOFN_OVERWRITEPROMPT = &H2
Global Const ahtOFN_HIDEREADONLY = &H4
Global Const ahtOFN_NOCHANGEDIR = &H8
Global Const ahtOFN_SHOWHELP = &H10
Global Const ahtOFN_NOVALIDATE = &H100
Global Const ahtOFN_ALLOWMULTISELECT = &H200
Global Const ahtOFN_EXTENSIONDIFFERENT = &H400
Global Const ahtOFN_PATHMUSTEXIST = &H800
Global Const ahtOFN_FILEMUSTEXIST = &H1000
Global Const ahtOFN_CREATEPROMPT = &H2000
Global Const ahtOFN_SHAREAWARE = &H4000
Global Const ahtOFN_NOREADONLYRETURN = &H8000
Global Const ahtOFN_NOTESTFILECREATE = &H10000
Global Const ahtOFN_NONETWORKBUTTON = &H20000
Global Const ahtOFN_NOLONGNAMES = &H40000

Function TestIt()
    Dim strFilter As String
    Dim lngFlags As Long
    strFilter = ahtAddFilterItem(strFilter, "Microsoft Project Files (*.mpp)", _
                    "*.MPP")
    strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")
    MsgBox "You selected: " & ahtCommonFileOpenSave(InitialDir:="C:\", _
        Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, _
        DialogTitle:="Hello! Open Me!")
    ' Since you passed in a variable for lngFlags,
    ' the function places the output flags value in the variable.
    'Debug.Print Hex(lngFlags)
End Function

Function GetOpenFile(Optional varDirectory As Variant, _
                     Optional strFilterName As String, _
                     Optional strFilterDesc As String, _
                     Optional varTitleForDialog As Variant) As Variant

Dim strFilter As String
Dim strFilterExt As String
Dim lngFlags As Long
Dim varFileName As Variant
' Specify that the chosen file must already exist,
' don't change directories when you're done
' Also, don't bother displaying
' the read-only box. It'll only confuse people.

lngFlags = ahtOFN_FILEMUSTEXIST Or _
            ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR

If IsMissing(varDirectory) Then
    varDirectory = ""
End If

If IsMissing(varTitleForDialog) Then
    varTitleForDialog = ""
End If

' Define the filter string and allocate space in the "c"
' string Duplicate this line with changes as necessary for
' more file templates.
'Default to "All Files" if strFilterName is empty.
'Set strFilter = strFilterName if strFilterName is not empty
'Set strFilterDesc = strFilterName & " Files"

If strFilterDesc = "" Then
    If strFilterName = "" Then
        strFilterDesc = "All Files (*.*)"
    Else
        strFilterExt = UCase(Mid(strFilterName, InStr(1, strFilterName, ".") + 1))
        strFilterDesc = strFilterExt & " Files"
    End If
End If

If strFilterName = "" Then
    strFilterName = "*.*"
End If

strFilter = ahtAddFilterItem(strFilter, strFilterDesc, strFilterName)
'strFilter = ahtAddFilterItem(strFilter, _
'            "Microsoft Project (*.mpp)", "*.MPP")
'strFilter = ahtAddFilterItem(strFilter, "Microsoft Excel Worksheet (*.xlsx)", _
'            "*.xlsx")

' Now actually call to get the file name.
varFileName = ahtCommonFileOpenSave( _
                OpenFile:=True, _
                InitialDir:=varDirectory, _
                Filter:=strFilter, _
                Flags:=lngFlags, _
                DialogTitle:=varTitleForDialog)

If Not IsNull(varFileName) Then
    varFileName = TrimNull(varFileName)
End If

GetOpenFile = varFileName

End Function


Function ahtCommonFileOpenSave( _
            Optional ByRef Flags As Variant, _
            Optional ByVal InitialDir As Variant, _
            Optional ByVal Filter As Variant, _
            Optional ByVal FilterIndex As Variant, _
            Optional ByVal DefaultExt As Variant, _
            Optional ByVal FileName As Variant, _
            Optional ByVal DialogTitle As Variant, _
            Optional ByVal hwnd As Variant, _
            Optional ByVal OpenFile As Variant) As Variant
' This is the entry point you'll use to call the common
' file open/save dialog. The parameters are listed
' below, and all are optional.
'
' In:
' Flags: one or more of the ahtOFN_* constants, OR'd together.
' InitialDir: the directory in which to first look
' Filter: a set of file filters, set up by calling
' AddFilterItem. See examples.
' FilterIndex: 1-based integer indicating which filter
' set to use, by default (1 if unspecified)
' DefaultExt: Extension to use if the user doesn't enter one.
' Only useful on file saves.
' FileName: Default value for the file name text box.
' DialogTitle: Title for the dialog.
' hWnd: parent window handle
' OpenFile: Boolean(True=Open File/False=Save As)
' Out:
' Return Value: Either Null or the selected filename

Dim OFN As tagOPENFILENAME
Dim strFileName As String
Dim strFileTitle As String
Dim fResult As Boolean

    ' Give the dialog a caption title.
    If IsMissing(InitialDir) Then InitialDir = CurDir
    If IsMissing(Filter) Then Filter = ""
    If IsMissing(FilterIndex) Then FilterIndex = 1
    If IsMissing(Flags) Then Flags = 0&
    If IsMissing(DefaultExt) Then DefaultExt = ""
    If IsMissing(FileName) Then FileName = ""
    If IsMissing(DialogTitle) Then DialogTitle = ""
    If IsMissing(hwnd) Then hwnd = 0                   '= Application.hwnd
    If IsMissing(OpenFile) Then OpenFile = True
    ' Allocate string space for the returned strings.
    strFileName = Left(FileName & String(256, 0), 256)
    strFileTitle = String(256, 0)
    ' Set up the data structure before you call the function

    With OFN
        .lStructSize = Len(OFN)
        .hwndOwner = hwnd
        .strFilter = Filter
        .nFilterIndex = FilterIndex
        .strFile = strFileName
        .nMaxFile = Len(strFileName)
        .strFileTitle = strFileTitle
        .nMaxFileTitle = Len(strFileTitle)
        .strTitle = DialogTitle
        .Flags = Flags
        .strDefExt = DefaultExt
        .strInitialDir = InitialDir
        ' Didn't think most people would want to deal with
        ' these options.
        .hInstance = 0
        '.strCustomFilter = ""
        '.nMaxCustFilter = 0
        .lpfnHook = 0
        'New for NT 4.0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255

    End With

    ' This will pass the desired data structure to the
    ' Windows API, which will in turn it uses to display
    ' the Open/Save As Dialog.
    If OpenFile Then
        fResult = aht_apiGetOpenFileName(OFN)
    Else
        fResult = aht_apiGetSaveFileName(OFN)
    End If

    ' The function call filled in the strFileTitle member
    ' of the structure. You'll have to write special code
    ' to retrieve that if you're interested.

    If fResult Then
        ' You might care to check the Flags member of the
        ' structure to get information about the chosen file.
        ' In this example, if you bothered to pass in a
        ' value for Flags, we'll fill it in with the outgoing
        ' Flags value.
        If Not IsMissing(Flags) Then Flags = OFN.Flags
        ahtCommonFileOpenSave = TrimNull(OFN.strFile)
    Else
        ahtCommonFileOpenSave = vbNullString
    End If

End Function


Function ahtAddFilterItem(strFilter As String, _
    strDescription As String, Optional varItem As Variant) As String
' Tack a new chunk onto the file filter.
' That is, take the old value, stick onto it the description,
' (like "Databases"), a null character, the skeleton
' (like "*.mdb;*.mda") and a final null character.
    If IsMissing(varItem) Then varItem = "*.*"
                ahtAddFilterItem = strFilter & _
                strDescription & vbNullChar & _
                varItem & vbNullChar
End Function


Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
    intPos = InStr(strItem, vbNullChar)
    If intPos > 0 Then
        TrimNull = Left(strItem, intPos - 1)
    Else
        TrimNull = strItem
    End If
End Function
'************** Code End *****************

Answer 1

I am going to suggest you consider (adopt) the built in file dialog. That code really goes back to the Access 97-2002 days!!!
(that's about 20 years now).

However, when Access 2003 was introduced, they added a built in file dialog.

There are several advantages.
First, it is now part of VBA.
Next, it works for x32 and x64 bit versions.

So, the code to pop the file browse dialog now can be this:

Dim f    As FileDialog
Set f = Application.FileDialog(msoFileDialogFilePicker) 
f.Show 
MsgBox "file choose was " & f.SelectedItems(1) 

You can late bind if you wish:

above needs: Microsoft Object 16.0 Object library, (or 15 or whatever version of acces you are using).

However - late bind is also possbile (you don't need a reference)


   Dim f    As Object 
   Set f = Application.FileDialog(3) 
   f.AllowMultiSelect = True 
   f.Show 

   MsgBox "file choosen = " & f.SelectedItems.Count 

so this allows you to dump that big long routine you posted. And typical code, say to browse for a pdf file could/would look like this:

    ' pop file dialog browser + select file

    Dim f    As Object
    Set f = Application.FileDialog(3)
'    Dim f As FileDialog
'    Set f = Application.FileDialog(msoFileDialogFilePicker)

   f.AllowMultiSelect = True
   f.Filters.Add "Pdf files", "*.pdf"

   f.Show

   If f.SelectedItems.Count = 0 Then
      ' use cancel
      Exit Sub
   End If

   ' show user selected files
   Dim sFile      As Variant
   For Each sFile In f.SelectedItems
      Debug.Print sFile
   Next

so, the beauty of this as noted is much less code, but even better, it works without changes to office x32 or office x64.

In theory, you would have to find the places in your application, but you could even re-create the function name used now that replaces the windows api. It going to be MORE trouble to update that windows API code to work with both x32, and x64 bit versions then the efforts to just start using the above VBA code.

Perhaps someone else will jump in, and post + share a x64 bit version of that "long" code, but even if someone does?

I think using the built in VBA file dialog ability is less work, and less hassle. I allows you to not have to deal with the windows API's, and that's always a challenge.

Regards,
Albert D. Kallal (Access MVP 2003-2017)
Edmonton, Alberta Canada

Answer 2

Hello,

I used the GetOpenFileName & GetSaveFileName libraries for serverly years and I was a bit surprised when they stop working with the new 64bit MSO.

I re-writed them and it seems they works correctly:

Option Explicit

#If VBA7 Then
    
    Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

    Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
    
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
    
    Private 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
#Else
    Private Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        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 Long
        lpfnHook As Long
        lpTemplateName As String
    End Type
#End If

Private Const ALL_FILES As String = "All files (*.*)" & vbNullChar & "*.*" & vbNullChar & vbNullChar
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_LONGNAMES As Long = &H200000

Public Const OFS_FILE_SAVE_FLAGS = OFN_EXPLORER _
             Or OFN_LONGNAMES _
             Or OFN_OVERWRITEPROMPT _
             Or OFN_HIDEREADONLY

'I used it to get the Excel form's handle (Sample: lPtr = GetWindowLongPtr("ThunderDFrame", Me.Caption)
Public Function GetWindowLongPtr(ByVal strClassName As String, ByVal strWindowName As String) As LongPtr
    GetWindowLongPtr = FindWindow(strClassName, strWindowName)
End Function

'sample string of filters for the dialog
'sFilters = "Microsoft Excel Workbook (*.xlsx)" & vbNullChar & _
              "*.xlsx" & vbNullChar & _
              "Microsoft Excel 97 Workbook (*.xls)" & vbNullChar & _
              "*.xls" & vbNullChar & _
              "All Files" & vbNullChar & _
              "*.*" & vbNullChar & vbNullChar

Public Function OpenDlg(ByVal hwndOwner As LongPtr, Optional ByVal strFilter As _
    String = ALL_FILES, Optional ByVal strWndTitle As String _
    = "Please select a file...", Optional ByVal strInitialPath As String = "C:\" & vbNullChar & vbNullChar, Optional intFilterIndex As Integer = 1) As String

    Dim OFName As OPENFILENAME
    Dim lReturn     As Long
    
    'Select a filter
    OFName.lpstrFilter = strFilter
    'Filter Index
    OFName.nFilterIndex = intFilterIndex
    'Set the parent window
    OFName.hwndOwner = hwndOwner
    'Set the application's instance
    OFName.hInstance = Application.HinstancePtr
    'create a buffer for the file
    OFName.lpstrFile = String(257, 0) 'Space$(254)
    #If VBA7 Then
        OFName.nMaxFile = LenB(OFName.lpstrFile) - 1
        OFName.lStructSize = LenB(OFName)
    #Else
        OFName.nMaxFile = Len(OFName.lpstrFile) - 1
        OFName.lStructSize = Len(OFName)
    #End If
    OFName.lpstrFileTitle = OFName.lpstrFile
    OFName.nMaxFileTitle = OFName.nMaxFile
    'Set the initial directory
    OFName.lpstrInitialDir = strInitialPath
    'Set the title
    OFName.lpstrTitle = strWndTitle
    'No flags
    OFName.flags = OFN_FILEMUSTEXIST + OFN_HIDEREADONLY + OFN_PATHMUSTEXIST
    'Show the 'Open File'-dialog
    lReturn = GetOpenFileName(OFName)
  
    If lReturn = 0 Then
        OpenDlg = ""
    Else
        OpenDlg = Trim(Left(OFName.lpstrFile, InStr(1, OFName.lpstrFile, vbNullChar) - 1))
    End If
   
End Function

Public Function ShowSave(ByVal hwndOwner As LongPtr, Optional ByVal strFilter As _
    String = ALL_FILES, Optional ByVal strWndTitle As String _
    = "Save as...", Optional ByVal strInitialPath As String = "C:\" & vbNullChar & vbNullChar, _
    Optional intFilterIndex As Integer = 1, Optional ByVal strFileName = "") As String

    Dim OFName As OPENFILENAME, lReturn As Long, strFile As String, idx As Integer
    
    Dim strExt() As String
    
    strExt = Split(Left(strFilter, Len(strFilter) - 2), vbNullChar)
    
    idx = intFilterIndex * 2 - 1
    
    OFName.lStructSize = Len(OFName)
    
    'Default extension
    OFName.lpstrDefExt = strExt(idx) & vbNullChar & vbNullChar
    'Select a filter
    OFName.lpstrFilter = strFilter
    'Filter Index
    OFName.nFilterIndex = intFilterIndex
    'Set the parent window
    OFName.hwndOwner = hwndOwner
    'Set the application's instance
    OFName.hInstance = Application.HinstancePtr
    'create a buffer for the file
    OFName.lpstrFile = strFileName & String(257, 0) 'Space$(254)
    #If VBA7 Then
        OFName.nMaxFile = LenB(OFName.lpstrFile) - 1
        OFName.lStructSize = LenB(OFName)
    #Else
        OFName.nMaxFile = Len(OFName.lpstrFile) - 1
        OFName.lStructSize = Len(OFName)
    #End If
    OFName.lpstrFileTitle = OFName.lpstrFile
    OFName.nMaxFileTitle = OFName.nMaxFile
    'Set the initial directory
    OFName.lpstrInitialDir = strInitialPath
    'Set the title
    OFName.lpstrTitle = strWndTitle
    'No flags
    OFName.flags = OFS_FILE_SAVE_FLAGS '  'OFN_PATHMUSTEXIST Or OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT '0
    
    'Show the 'Open File'-dialog
    lReturn = GetSaveFileName(OFName)
  
    If lReturn = 0 Then
        ShowSave = ""
    Else
        ShowSave = Trim(Left(OFName.lpstrFile, InStr(1, OFName.lpstrFile, vbNullChar) - 1))
    End If
   
    
End Function