• Home
 · 
• Windows API Call/Explanation
 · 
• Browse For Folder

Browse For Folder

Browse For Folder

Rate Browse For Folder

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

Public Const MAX_PATH = 260

Private Type BrowseInfo
  hWndOwner      As Long
  pIDLRoot       As Long
  pszDisplayName As Long
  lpszTitle      As Long
  ulFlags        As Long
  lpfnCallback   As Long
  lParam         As Long
  iImage         As Long
End Type

Private Type SHITEMID
    cb As Long
    abID As Byte
End Type

Private Type ITEMIDLIST
    mkid As SHITEMID
End Type

Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)

Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHParseDisplayName Lib "shell32.dll" (ByVal pszName As Long, ByVal pbc As Long, ByRef ppidl As Long, ByVal sfgaoIn As Long, ByRef psfgaoOut As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

Private m_CurrentDirectory As String

Private Function GetAddressofFunction(add As Long) As Long
  GetAddressofFunction = add
End Function

Private Function BrowseCallbackProc(ByVal HWND As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
  On Local Error Resume Next
  Dim lpIDList As Long
  Dim ret As Long
  Dim sBuffer As String
  Select Case uMsg
    Case BFFM_INITIALIZED
      SendMessage HWND, BFFM_SETSELECTION, 1, m_CurrentDirectory
    Case BFFM_SELCHANGED
      sBuffer = Space(MAX_PATH)
      ret = SHGetPathFromIDList(lp, sBuffer)
      If ret = 1 Then
        SendMessage HWND, BFFM_SETSTATUSTEXT, 0, sBuffer
      End If
  End Select
  BrowseCallbackProc = 0
End Function

Public Function BrowseForFolder(Optional ByVal Title As String = "", Optional ByVal RootDir As String = "", Optional ByVal StartDir As String = "", Optional owner As Form = Nothing, Optional IncludeFiles As Boolean = False) As String
  Const BIF_STATUSTEXT = &H4
  Const BIF_RETURNONLYFSDIRS = &H1
  Const BIF_BROWSEINCLUDEFILES = &H4000
  Dim lpIDList As Long, lpIDList2 As Long, IDL As ITEMIDLIST
  Dim sBuffer As String, tBrowseInfo As BrowseInfo, r As Long
  If Len(RootDir) > 0 Then
    If PathIsDirectory(RootDir) Then
      SHParseDisplayName StrPtr(RootDir), ByVal 0&, lpIDList2, ByVal 0&, ByVal 0&
      tBrowseInfo.pIDLRoot = lpIDList2
    Else
      r = SHGetSpecialFolderLocation(ByVal 0&, &H11, IDL)
      If r = 0 Then tBrowseInfo.pIDLRoot = IDL.mkid.cb
    End If
  Else
    r = SHGetSpecialFolderLocation(ByVal 0&, &H11, IDL)
    If r = 0 Then tBrowseInfo.pIDLRoot = IDL.mkid.cb
  End If
  If Len(StartDir) > 0 Then
    m_CurrentDirectory = StartDir & vbNullChar
  Else
    m_CurrentDirectory = vbNullChar
  End If
  If Len(Title) > 0 Then
    tBrowseInfo.lpszTitle = lstrcat(Title, "")
  Else
    tBrowseInfo.lpszTitle = lstrcat("Select A Directory", "")
  End If
  tBrowseInfo.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)
  If IncludeFiles = True Then
    tBrowseInfo.ulFlags = BIF_STATUSTEXT + BIF_RETURNONLYFSDIRS + BIF_BROWSEINCLUDEFILES
  Else
    tBrowseInfo.ulFlags = BIF_STATUSTEXT + BIF_RETURNONLYFSDIRS
  End If
  If Not (owner Is Nothing) Then tBrowseInfo.hWndOwner = owner.HWND
  lpIDList = SHBrowseForFolder(tBrowseInfo)
  If Len(RootDir) > 0 Then
    If PathIsDirectory(RootDir) Then CoTaskMemFree lpIDList2
  End If
  If (lpIDList) Then
    sBuffer = Space(MAX_PATH)
    SHGetPathFromIDList lpIDList, sBuffer
    CoTaskMemFree lpIDList
    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    BrowseForFolder = sBuffer
  Else
    BrowseForFolder = ""
  End If
End Function