Author Topic: 'Browse for folder' system dialog box in 64-Bit VBA 7.1  (Read 9411 times)

0 Members and 1 Guest are viewing this topic.

Patch61

  • Guest
'Browse for folder' system dialog box in 64-Bit VBA 7.1
« on: August 07, 2014, 01:33:50 AM »
This module will allow you to use the Windows system SHBrowseForFolder dialog in 64-bit VBA 7.1.

Code: [Select]

'##########################################################################################
'#                                                                                        #
'#                                modFolderBrowse                                         #
'#                               code compiled by                                         #
'#                                Steven Elliott                                          #
'#                          from many sources on the net                                  #
'#                           Released to Public Domain                                    #
'#                                                                                        #
'##########################################################################################

Option Explicit
       
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long
 
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
        (ByVal pidList As Long, ByVal lpBuffer As String) As Long
 
Public Declare PtrSafe Function SendMessageA Lib "user32" _
      (ByVal hWnd As LongPtr, ByVal wMsg As Long, _
       ByVal wParam As LongPtr, lParam As Any) As LongPtr
 
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)

Private Const BIF_RETURNONLYFSDIRS  As Long = 1
Private Const CSIDL_DRIVES          As Long = &H11
Private Const WM_USER               As Long = &H400
Private Const MAX_PATH              As Long = 260 ' Is it a bad thing that I memorized this value?

'// message from browser
Private Const BFFM_INITIALIZED     As Long = 1
Private Const BFFM_SELCHANGED      As Long = 2
Private Const BFFM_VALIDATEFAILEDA As Long = 3 '// lParam:szPath ret:1(cont),0(EndDialog)
Private Const BFFM_VALIDATEFAILEDW As Long = 4 '// lParam:wzPath ret:1(cont),0(EndDialog)
Private Const BFFM_IUNKNOWN        As Long = 5 '// provides IUnknown to client. lParam: IUnknown*

'// messages to browser
Private Const BFFM_SETSTATUSTEXTA   As Long = WM_USER + 100
Private Const BFFM_ENABLEOK         As Long = WM_USER + 101
Private Const BFFM_SETSELECTIONA    As Long = WM_USER + 102
Private Const BFFM_SETSELECTIONW    As Long = WM_USER + 103
Private Const BFFM_SETSTATUSTEXTW   As Long = WM_USER + 104
Private Const BFFM_SETOKTEXT        As Long = WM_USER + 105 '// Unicode only
Private Const BFFM_SETEXPANDED      As Long = WM_USER + 106 '// Unicode only
       

Public Type BrowseInfo
  hWndOwner As LongPtr
  pIDLRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfnCallback As LongPtr
  lParam As LongPtr
  iImage As Long
End Type

Private Function PtrToFunction(ByVal lFcnPtr As LongPtr) As LongPtr
  PtrToFunction = lFcnPtr
End Function

Private Function CorrectPath(ByVal sPath As String) As String
  If Right$(sPath, 1) = "\" Then
    If Len(sPath) > 3 Then sPath = Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root
  Else
    If Len(sPath) = 2 Then sPath = sPath & "\"                  ' Append backslash to root
  End If
  CorrectPath = sPath
End Function

Public Function FolderBrowse(ByVal sDialogTitle As String, ByVal sPath As String) As String
  Dim ReturnPath As String
 
  Dim b(MAX_PATH) As Byte
  Dim pItem       As Long
  Dim sFullPath   As String
  Dim bi          As BrowseInfo
  Dim ppidl       As Long
 
  sPath = CorrectPath(sPath)
 
  bi.hWndOwner = 0 'Screen.ActiveForm.hwnd

  'SHGetSpecialFolderLocation bi.hWndOwner, CSIDL_DRIVES, ppidl

  bi.pIDLRoot = 0 'ppidl

  bi.pszDisplayName = VarPtr(b(0))
  bi.lpszTitle = sDialogTitle
  bi.ulFlags = BIF_RETURNONLYFSDIRS
  If FolderExists(sPath) Then bi.lpfnCallback = PtrToFunction(AddressOf BFFCallback)
  bi.lParam = StrPtr(sPath)

  pItem = SHBrowseForFolder(bi)
 
  If pItem Then ' Succeeded
    sFullPath = Space$(MAX_PATH)
    If SHGetPathFromIDList(pItem, sFullPath) Then
      ReturnPath = Left$(sFullPath, InStr(sFullPath, vbNullChar) - 1) ' Strip nulls
      CoTaskMemFree pItem
    End If
  End If
 
  If Right$(ReturnPath, 1) <> "\" And ReturnPath <> "" Then  'Could be "C:"
    FolderBrowse = ReturnPath & "\"
  End If
 
End Function


Public Function BFFCallback(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal sData As String) As Long
  If uMsg = BFFM_INITIALIZED Then
    SendMessageA hWnd, BFFM_SETSELECTIONA, True, ByVal sData
  End If
End Function

Public Function FolderExists(ByVal sFolderName As String) As Boolean
   Dim att As Long
   On Error Resume Next
   att = GetAttr(sFolderName)
   If Err.Number = 0 Then
      FolderExists = True
   Else
      Err.Clear
      FolderExists = False
   End If
   On Error GoTo 0
End Function


Use it with the simple calls below:
Code: [Select]

Private Sub cmdGetLibraryPath_Click()
   Dim sPath As String
'                          FolderBrowse(DialogBoxTitle, StartingPath)
   sPath = modFolderBrowse.FolderBrowse("Select Folder Containing Block Library", txtLibraryPath.Text)
   If sPath <> "" Then
      If modFolderBrowse.FolderExists(sPath) Then
         txtLibraryPath.Text = sPath
      End If
   End If
End Sub


zzyong00

  • Guest
Re: 'Browse for folder' system dialog box in 64-Bit VBA 7.1
« Reply #1 on: April 29, 2015, 11:28:21 AM »
It's great!
Can you achieve "opendialog" and "savedialog" in 64-Bit VBA7.1?

57gmc

  • Newt
  • Posts: 103
Re: 'Browse for folder' system dialog box in 64-Bit VBA 7.1
« Reply #2 on: September 29, 2020, 05:36:58 PM »
The code crashes AutoCAD on this line:
If SHGetPathFromIDList(pItem, sFullPath) Then

Alexander Rivilis

  • Bull Frog
  • Posts: 213
  • Programmer from Kyiv (Ukraine)
Re: 'Browse for folder' system dialog box in 64-Bit VBA 7.1
« Reply #3 on: October 05, 2020, 09:52:54 AM »
Change
Code - vb.net: [Select]
  1. Dim pItem       As Long
with
Code - vb.net: [Select]
  1. Dim pItem       As LongPtr

Code - vb.net: [Select]
  1.     Option Explicit
  2.     '----------------------------------------------------------------------
  3.     ' 64 bit VBA 7 version of File and Folder Browswers
  4.     ' FileBrowseOpen() ' FileBrowseSave() ' FolderBrowse()
  5.     '----------------------------------------------------------------------
  6.      
  7.     Public Declare PtrSafe Function SendMessageA Lib "user32" _
  8.     (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
  9.      
  10.     Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
  11.     Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
  12.      
  13.     Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
  14.     Alias "SHGetPathFromIDListA" (ByVal pidList As LongPtr, ByVal lpBuffer As String) As Boolean
  15.      
  16.     Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)
  17.      
  18.     Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
  19.     "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
  20.      
  21.     Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
  22.     "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
  23.      
  24.     Private Const BIF_RETURNONLYFSDIRS As Long = 1
  25.     Private Const CSIDL_DRIVES As Long = &H11
  26.     Private Const WM_USER As Long = &H400
  27.     Private Const MAX_PATH As Long = 260
  28.      
  29.     '// message from browser
  30.     Private Const BFFM_INITIALIZED As Long = 1
  31.     Private Const BFFM_SELCHANGED As Long = 2
  32.     Private Const BFFM_VALIDATEFAILEDA As Long = 3 '// lParam:szPath ret:1(cont),0(EndDialog)
  33.     Private Const BFFM_VALIDATEFAILEDW As Long = 4 '// lParam:wzPath ret:1(cont),0(EndDialog)
  34.     Private Const BFFM_IUNKNOWN As Long = 5 '// provides IUnknown to client. lParam: IUnknown*
  35.      
  36.     '// messages to browser
  37.     Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100
  38.     Private Const BFFM_ENABLEOK As Long = WM_USER + 101
  39.     Private Const BFFM_SETSELECTIONA As Long = WM_USER + 102
  40.     Private Const BFFM_SETSELECTIONW As Long = WM_USER + 103
  41.     Private Const BFFM_SETSTATUSTEXTW As Long = WM_USER + 104
  42.     Private Const BFFM_SETOKTEXT As Long = WM_USER + 105 '// Unicode only
  43.     Private Const BFFM_SETEXPANDED As Long = WM_USER + 106 '// Unicode only
  44.      
  45.     Public Const OFN_ALLOWMULTISELECT As Long = &H200
  46.     Public Const OFN_CREATEPROMPT As Long = &H2000
  47.     Public Const OFN_ENABLEHOOK As Long = &H20
  48.     Public Const OFN_ENABLETEMPLATE As Long = &H40
  49.     Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
  50.     Public Const OFN_EXPLORER As Long = &H80000
  51.     Public Const OFN_EXTENSIONDIFFERENT As Long = &H400
  52.     Public Const OFN_FILEMUSTEXIST As Long = &H1000
  53.     Public Const OFN_HIDEREADONLY As Long = &H4
  54.     Public Const OFN_LONGNAMES As Long = &H200000
  55.     Public Const OFN_NOCHANGEDIR As Long = &H8
  56.     Public Const OFN_NODEREFERENCELINKS As Long = &H100000
  57.     Public Const OFN_NOLONGNAMES As Long = &H40000
  58.     Public Const OFN_NONETWORKBUTTON As Long = &H20000
  59.     Public Const OFN_NOREADONLYRETURN As Long = &H8000& '*see comments
  60.     Public Const OFN_NOTESTFILECREATE As Long = &H10000
  61.     Public Const OFN_NOVALIDATE As Long = &H100
  62.     Public Const OFN_OVERWRITEPROMPT As Long = &H2
  63.     Public Const OFN_PATHMUSTEXIST As Long = &H800
  64.     Public Const OFN_READONLY As Long = &H1
  65.     Public Const OFN_SHAREAWARE As Long = &H4000
  66.     Public Const OFN_SHAREFALLTHROUGH As Long = 2
  67.     Public Const OFN_SHAREWARN As Long = 0
  68.     Public Const OFN_SHARENOWARN As Long = 1
  69.     Public Const OFN_SHOWHELP As Long = &H10
  70.     Public Const OFN_ENABLESIZING As Long = &H800000
  71.     Public Const OFS_MAXPATHNAME As Long = 260
  72.      
  73.     Private Type OPENFILENAME
  74.     lStructSize As Long
  75.     hWndOwner As LongPtr
  76.     hInstance As LongPtr
  77.     lpstrFilter As String
  78.     lpstrCustomFilter As String
  79.     nMaxCustFilter As Long
  80.     nFilterIndex As Long
  81.     lpstrFile As String
  82.     nMaxFile As Long
  83.     lpstrFileTitle As String
  84.     nMaxFileTitle As Long
  85.     lpstrInitialDir As String
  86.     lpstrTitle As String
  87.     flags As Long
  88.     nFileOffset As Integer
  89.     nFileExtension As Integer
  90.     lpstrDefExt As String
  91.     lCustData As Long
  92.     lpfnHook As LongPtr
  93.     lpTemplateName As String
  94.     End Type
  95.      
  96.     Public Type BROWSEINFO
  97.             hWndOwner As LongPtr
  98.             pidlRoot As LongPtr
  99.             pszDisplayName As String
  100.             lpszTitle As String
  101.             ulFlags As Long
  102.             lpfnCallback As LongPtr
  103.             lParam As LongPtr
  104.             iImage As Long
  105.     End Type
  106.      
  107.     '====== Folder Browser for 64 bit VBA 7 ========
  108.     Public Function FolderBrowse(ByVal sDialogTitle As String, ByVal sInitFolder As String) As String
  109.     Dim ReturnPath As String
  110.      
  111.     Dim b(MAX_PATH) As Byte
  112.     Dim pItem As LongPtr
  113.     Dim sFullPath As String
  114.     Dim bi As BROWSEINFO
  115.     Dim ppidl As Long
  116.      
  117.     sInitFolder = CorrectPath(sInitFolder)
  118.      
  119.     ' Note VBA windows and dialogs do not have an hWnd property.
  120.     bi.hWndOwner = 0 'Windows Main Screen handle.
  121.      
  122.     bi.pidlRoot = 0 'ppidl
  123.      
  124.     bi.pszDisplayName = VarPtr(b(0))
  125.     bi.lpszTitle = sDialogTitle
  126.     bi.ulFlags = BIF_RETURNONLYFSDIRS
  127.     If FolderExists(sInitFolder) Then bi.lpfnCallback = PtrToFunction(AddressOf BFFCallback)
  128.     bi.lParam = StrPtr(sInitFolder)
  129.      
  130.     pItem = SHBrowseForFolder(bi)
  131.      
  132.     If pItem Then ' Succeeded
  133.     sFullPath = Space$(MAX_PATH)
  134.     If SHGetPathFromIDList(pItem, sFullPath) Then
  135.     ReturnPath = Left$(sFullPath, InStr(sFullPath, vbNullChar) - 1) ' Strip nulls
  136.     CoTaskMemFree pItem
  137.     End If
  138.     End If
  139.      
  140.     If ReturnPath <> "" Then
  141.     If Right$(ReturnPath, 1) <> "\" Then
  142.     ReturnPath = ReturnPath & "\"
  143.     End If
  144.     End If
  145.      
  146.     FolderBrowse = ReturnPath
  147.     End Function
  148.      
  149.     ' typedef int (CALLBACK* BFFCALLBACK)(HWND hwnd, UINT uMsg, LPARAM lParam, LPARAM lpData);
  150.     Private Function BFFCallback(ByVal hWnd As LongPtr, ByVal uMsg As LongPtr, ByVal lParam As LongPtr, ByVal sData As String) As LongPtr
  151.     If uMsg = BFFM_INITIALIZED Then
  152.     SendMessageA hWnd, BFFM_SETSELECTIONA, True, ByVal sData
  153.     End If
  154.     End Function
  155.      
  156.     Private Function PtrToFunction(ByVal lFcnPtr As LongPtr) As LongPtr
  157.     PtrToFunction = lFcnPtr
  158.     End Function
  159.      
  160.     Private Function CorrectPath(ByVal sPath As String) As String
  161.     If Right$(sPath, 1) = "\" Then
  162.     If Len(sPath) > 3 Then sPath = Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root
  163.     Else
  164.     If Len(sPath) = 2 Then sPath = sPath & "\" ' Append backslash to root
  165.     End If
  166.     CorrectPath = sPath
  167.     End Function
  168.      
  169.     Public Function FolderExists(ByVal sFolderName As String) As Boolean
  170.     Dim att As Long
  171.     On Error Resume Next
  172.     att = GetAttr(sFolderName)
  173.     If Err.Number = 0 Then
  174.     FolderExists = True
  175.     Else
  176.     Err.Clear
  177.     FolderExists = False
  178.     End If
  179.     On Error GoTo 0
  180.     End Function

Keith™

  • Villiage Idiot
  • Seagull
  • Posts: 16828
  • Superior Stupidity at its best
Re: 'Browse for folder' system dialog box in 64-Bit VBA 7.1
« Reply #4 on: October 05, 2020, 07:15:32 PM »
I have a very similar function
Proud provider of opinion and arrogance since November 22, 2003 at 09:35:31 am
CadJockey Militia Field Marshal

Find me on https://parler.com @kblackie

57gmc

  • Newt
  • Posts: 103
Re: 'Browse for folder' system dialog box in 64-Bit VBA 7.1
« Reply #5 on: October 06, 2020, 02:07:46 PM »
Thanks Alexander, Keith. I found one here that has some nice features.