Option Compare Database
Option Explicit
'************** Code Start **************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Terry Kreft
'Some modifications made by Peter De Baets of
'Peter's Software - http://www.peterssoftware.com
'
'FYI: The file open/save dialog module can be found here:
'http://www.mvps.org/access/api/api0001.htm
'
' modified by agpuzon for x64 system
'
#If VBA7 Then
Private Type BROWSEINFO
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As LongPtr, ByVal pszPath As String) As Long
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As LongPtr
#Else
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
#End If
Private Const BIF_RETURNONLYFSDIRS = &H1
Public Function BrowseFolder(Optional szDialogTitle As String = "") As String
'* This function returns a folder selected in the Windows folder browse common dialog
'* it was modified by Peter De Baets to always return a folder string with a trailing "\"
Dim x As Long, bi As BROWSEINFO
#If VBA7 Then
Dim dwIList As LongPtr
#Else
Dim dwIList As Long
#End If
Dim szPath As String, wPos As Integer
Dim strRtn As String
strRtn = ""
With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
'szPath = String$(512, Chr(0))
x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If x Then
wPos = InStr(szPath, Chr(0))
strRtn = left$(szPath, wPos - 1)
Else
strRtn = ""
End If
'* Make sure that the folder is always returned with a backslash at the end
If right(strRtn, 1) = "\" Then
Else
If IsNull(strRtn) Or strRtn = "" Then
Else
strRtn = strRtn & "\"
End If
End If
BrowseFolder = strRtn
End Function
