PtrSafe GetOpenfileName (1 Viewer)

Asde

New member
Local time
Tomorrow, 00:49
Joined
Feb 22, 2018
Messages
5
Hello All

I'm having problems making GetOpenFileNamea Access project to 64 bit version.
All the resolutions on the internet involve including PtrSafe and although this removes the message it does not show the dialog anymore to select a file..

I've been staring at this for days now and hope someone can assist me in what the problem may be.

Below is the code used for module mod_API

Code:
Option Explicit
Option Compare Database

' Declare the API-functions needed
Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Public Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
    "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

' Declare Access-structure for dialog_boxes...
Public 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"

' Declare API-structure
Public Type OPENFILENAME
    lStructSize As Long
    hwndOwner As LongPtr
    hInstance As LongPtr
    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 LongPtr
    lpfnHook As LongPtr
    lpTemplateName As Long
End Type

' Declare constants for dialog creation
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


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

Function MSA_ConvertFilterString(strFilterIn As String) As String
' Creates a filter string from a bar ("|") separated string.
' The string should pairs of filter|extension strings, i.e. "Access Databases|*.mdb|All Files|*.*"
' If no extensions exists for the last filter pair, *.* is added.
' This code will ignore any empty strings, i.e. "||" pairs.
' Returns "" if the strings passed in is empty.

    
    Dim strFilter As String
    Dim intNum As Integer, intPos As Integer, intLastPos As Integer

    strFilter = ""
    intNum = 0
    intPos = 1
    intLastPos = 1

    ' Add strings as long as we find bars.
    ' Ignore any empty strings (not allowed).
    Do
        intPos = InStr(intLastPos, strFilterIn, "|")
        If (intPos > intLastPos) Then
            strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
            intNum = intNum + 1
            intLastPos = intPos + 1
        ElseIf (intPos = intLastPos) Then
            intLastPos = intPos + 1
        End If
    Loop Until (intPos = 0)
        
    ' Get last string if it exists (assuming strFilterIn was not bar terminated).
    intPos = Len(strFilterIn)
    If (intPos >= intLastPos) Then
        strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
        intNum = intNum + 1
    End If
    
    ' Add *.* if there's no extension for the last string.
    If intNum Mod 2 = 1 Then
        strFilter = strFilter & "*.*" & vbNullChar
    End If
    
    ' Add terminating NULL if we have any filter.
    If strFilter <> "" Then
        strFilter = strFilter & vbNullChar
    End If
    
    MSA_ConvertFilterString = strFilter
End Function

 Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the file save dialog.
    
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    of.Flags = of.Flags Or OFN_HIDEREADONLY Or OFN_NOVALIDATE
    intRet = GetSaveFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetSaveFileName = intRet
End Function

Function MSA_SimpleGetSaveFileName() As String
' Opens the file save dialog with default values.

    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
    
    intRet = MSA_GetSaveFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    
    MSA_SimpleGetSaveFileName = strRet
End Function

Public 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


Function MSA_SimpleGetOpenFileName() As String
' Opens the Open dialog with default values.
    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
    
    intRet = MSA_GetOpenFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    MSA_SimpleGetOpenFileName = strRet
End Function


Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
' This sub converts from the Win32 structure to the Microsoft Access structure.
    msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
    msaof.strFileNameReturned = of.lpstrFileTitle
    msaof.intFileOffset = of.nFileOffset
    msaof.intFileExtension = of.nFileExtension
End Sub

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 - LenB(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
 

MarkK

bit cruncher
Local time
Today, 15:49
Joined
Mar 17, 2004
Messages
7,851
I would check out the FileDialog object provided by the Office object model, so in a code window, go to MainMenu->Tools->References and add a reference to the "Microsoft Office XX.0 Object Library," and then search for FileDialog in the object browser, and you can get info on how to do that job without using Windows API calls.
hth
Mark
 

isladogs

CID VIP
Local time
Today, 23:49
Joined
Jan 14, 2017
Messages
15,516
I had the same problem a couple of year ago and replaced with the following code:

Code:
Private Sub cmdBrowse_Click()
    
On Error GoTo Err_cmdBrowse_Click

'CR 28/08/2015 - Code rewritten to ensure compatibility with 64-bit Office

' Set options for the dialog box.
    Dim F As FileDialog
    Set F = Application.FileDialog(msoFileDialogFilePicker)
    F.Title = "Locate the file to be attached and click on 'Open'"
    F.AllowMultiSelect = False
    
' Clear out the current filters
    F.Filters.Clear
    
' Set the start folder
    F.InitialFileName = "c:\"
    
' Call the Open dialog routine.
    F.Show

' Return the path and file name.
    'strFileName = FindFilePath("C:\")
    strFileName = F.SelectedItems(1)
    
    Me.txtFile = strFileName

Exit_cmdBrowse_Click:
    Exit Sub

Err_cmdBrowse_Click:
    'err=5, user clicked cancel
    If Err.Number = 5 Then Exit Sub
        
    MsgBox "Error " & Err.Number & " in cmdBrowse_Click procedure : " & Err.Description
    Resume Exit_cmdBrowse_Click
    
End Sub

The example database attached uses this code so you can try before you 'buy'
 

Attachments

  • Browse&AttachFile.zip
    38.6 KB · Views: 231

Asde

New member
Local time
Tomorrow, 00:49
Joined
Feb 22, 2018
Messages
5
Thank you for your efforts! but I'm still struggling.

Both the Filedialog suggested by MarkK and the browse button in the attached database by ridders just dont pop-up.
I added the correct references and installed the IDBE tools :(
 

isladogs

CID VIP
Local time
Today, 23:49
Joined
Jan 14, 2017
Messages
15,516
Thank you for your efforts! but I'm still struggling.

Both the Filedialog suggested by MarkK and the browse button in the attached database by ridders just dont pop-up.
I added the correct references and installed the IDBE tools :(

IDBE Tools is a nice add in but not needed for my utility.

What do you mean by 'the browse button doesn't popup?
What DOES happen?
Is that using my utility or after putting the code in your own db?
Which references do you have installed with my utility?
 

Asde

New member
Local time
Tomorrow, 00:49
Joined
Feb 22, 2018
Messages
5
IDBE Tools is a nice add in but not needed for my utility.

What do you mean by 'the browse button doesn't popup?
What DOES happen?
Is that using my utility or after putting the code in your own db?
Which references do you have installed with my utility?

When the form start and I click the browse button on your utility, nothing happens.

References:

Visual Basic For applications
Microsoft access 16.0 library
OLE Automation
Microsoft Office 16.0 Access dataabse engine objects
Microsoft office 16.0 Object library
Microsoft Forms 2.0 Object library
IDBETools2010x64
 

Asde

New member
Local time
Tomorrow, 00:49
Joined
Feb 22, 2018
Messages
5
this works now I just need to find how to implement this in the code

Code:
Function getFileName() As String
    Dim fDialog As Object
    Set fDialog = Application.FileDialog(3)
    Dim varFile As Variant
    With fDialog
       .AllowMultiSelect = False
        If .Show = True Then
           For Each varFile In .SelectedItems
             getFileName = varFile
           Next
        End If
    End With
End Function
 

isladogs

CID VIP
Local time
Today, 23:49
Joined
Jan 14, 2017
Messages
15,516
this works now I just need to find how to implement this in the code

Code:
Function getFileName() As String
    Dim fDialog As Object
    Set fDialog = Application.FileDialog(3)
    Dim varFile As Variant
    With fDialog
       .AllowMultiSelect = False
        If .Show = True Then
           For Each varFile In .SelectedItems
             getFileName = varFile
           Next
        End If
    End With
End Function

You do realise this is just a variation on the code I supplied
The (3) means the same as (msoFileDialogFilePicker)
I just prefer the long version so I can see at a glance what its doing

Just place the code as your button click code instead of mycmdBrowse_Click

OR use

Code:
Private Sub cmdBrowse_Click()

getFileName

End Sub

BTW - although I use IDBETools, I've never added it as a VBA reference.
What functionality does it add?
 

Asde

New member
Local time
Tomorrow, 00:49
Joined
Feb 22, 2018
Messages
5
Yeah I realise that :)
msoFileDialogFilePicker could not be recognized so I searched in the direction you sent me and came up with 3

As far as I know, it just adds a toolbar in the VB window, besides that I couldn't tell.. this will is the first time I'm working on a Access database.

To bad the code that I originally posted cannot be converted in some way as now I'll have to rewrite the code
 

isladogs

CID VIP
Local time
Today, 23:49
Joined
Jan 14, 2017
Messages
15,516
I used to have all that code in post #1
If I remember correctly it came from the Access Web (Dev Ashish)

I didn't rewrite any of it - I just replaced it all
 

Users who are viewing this thread

Top Bottom