Code Red > VB(A)

'Browse for folder' system dialog box in 64-Bit VBA 7.1

(1/2) > >>

Patch61:
This module will allow you to use the Windows system SHBrowseForFolder dialog in 64-bit VBA 7.1.


--- Code: ---
'##########################################################################################
'#                                                                                        #
'#                                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


--- End code ---

Use it with the simple calls below:

--- Code: ---
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


--- End code ---

zzyong00:
It's great!
Can you achieve "opendialog" and "savedialog" in 64-Bit VBA7.1?

57gmc:
The code crashes AutoCAD on this line:
If SHGetPathFromIDList(pItem, sFullPath) Then

Alexander Rivilis:
Change

--- Code - vb.net: ---Dim pItem       As Longwith

--- Code - vb.net: ---Dim pItem       As LongPtr

--- Code - vb.net: ---    Option Explicit    '----------------------------------------------------------------------    ' 64 bit VBA 7 version of File and Folder Browswers    ' FileBrowseOpen() ' FileBrowseSave() ' FolderBrowse()    '----------------------------------------------------------------------         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 Function SHBrowseForFolder Lib "shell32.dll" _    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr         Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _    Alias "SHGetPathFromIDListA" (ByVal pidList As LongPtr, ByVal lpBuffer As String) As Boolean         Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)         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 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         '// 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 Const OFN_ALLOWMULTISELECT As Long = &H200    Public Const OFN_CREATEPROMPT As Long = &H2000    Public Const OFN_ENABLEHOOK As Long = &H20    Public Const OFN_ENABLETEMPLATE As Long = &H40    Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80    Public Const OFN_EXPLORER As Long = &H80000    Public Const OFN_EXTENSIONDIFFERENT As Long = &H400    Public Const OFN_FILEMUSTEXIST As Long = &H1000    Public Const OFN_HIDEREADONLY As Long = &H4    Public Const OFN_LONGNAMES As Long = &H200000    Public Const OFN_NOCHANGEDIR As Long = &H8    Public Const OFN_NODEREFERENCELINKS As Long = &H100000    Public Const OFN_NOLONGNAMES As Long = &H40000    Public Const OFN_NONETWORKBUTTON As Long = &H20000    Public Const OFN_NOREADONLYRETURN As Long = &H8000& '*see comments    Public Const OFN_NOTESTFILECREATE As Long = &H10000    Public Const OFN_NOVALIDATE As Long = &H100    Public Const OFN_OVERWRITEPROMPT As Long = &H2    Public Const OFN_PATHMUSTEXIST As Long = &H800    Public Const OFN_READONLY As Long = &H1    Public Const OFN_SHAREAWARE As Long = &H4000    Public Const OFN_SHAREFALLTHROUGH As Long = 2    Public Const OFN_SHAREWARN As Long = 0    Public Const OFN_SHARENOWARN As Long = 1    Public Const OFN_SHOWHELP As Long = &H10    Public Const OFN_ENABLESIZING As Long = &H800000    Public Const OFS_MAXPATHNAME As Long = 260         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 Long    lpfnHook As LongPtr    lpTemplateName As String    End Type         Public Type BROWSEINFO            hWndOwner As LongPtr            pidlRoot As LongPtr            pszDisplayName As String            lpszTitle As String            ulFlags As Long            lpfnCallback As LongPtr            lParam As LongPtr            iImage As Long    End Type         '====== Folder Browser for 64 bit VBA 7 ========    Public Function FolderBrowse(ByVal sDialogTitle As String, ByVal sInitFolder As String) As String    Dim ReturnPath As String         Dim b(MAX_PATH) As Byte    Dim pItem As LongPtr    Dim sFullPath As String    Dim bi As BROWSEINFO    Dim ppidl As Long         sInitFolder = CorrectPath(sInitFolder)         ' Note VBA windows and dialogs do not have an hWnd property.    bi.hWndOwner = 0 'Windows Main Screen handle.         bi.pidlRoot = 0 'ppidl         bi.pszDisplayName = VarPtr(b(0))    bi.lpszTitle = sDialogTitle    bi.ulFlags = BIF_RETURNONLYFSDIRS    If FolderExists(sInitFolder) Then bi.lpfnCallback = PtrToFunction(AddressOf BFFCallback)    bi.lParam = StrPtr(sInitFolder)         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 ReturnPath <> "" Then    If Right$(ReturnPath, 1) <> "\" Then    ReturnPath = ReturnPath & "\"    End If    End If         FolderBrowse = ReturnPath    End Function         ' typedef int (CALLBACK* BFFCALLBACK)(HWND hwnd, UINT uMsg, LPARAM lParam, LPARAM lpData);    Private Function BFFCallback(ByVal hWnd As LongPtr, ByVal uMsg As LongPtr, ByVal lParam As LongPtr, ByVal sData As String) As LongPtr    If uMsg = BFFM_INITIALIZED Then    SendMessageA hWnd, BFFM_SETSELECTIONA, True, ByVal sData    End If    End Function         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 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

Keith™:
I have a very similar function

Navigation

[0] Message Index

[#] Next page