ChooseFolderEx
![]()
Project Summary
So if you've ever used a folder choose based on SHBrowseForFolder, you'll notice that most functions that turn its result (a pidl) into a file system path will return nothing, or at best a cryptic string starting with :: (followed by a GUID). But things like Libraries, My Computer, and Network contain folders- and if you're going to be doing something like searching for files, the user may well expect that selecting one of those would search its locations. Thanks to oleexp, the code to find out what those folders are is at least somewhat manageable.
Project Requirements
-At least Windows Vista; Libraries are a Win7+ thing.
-oleexp3.tlb - my fork of olelib with modern interfaces (get it here). This must be added as a reference under Project->References, but doesn't need to be included with a compiled program. No new version was released with this project, so if you already have it you don't need to upgrade this time.
So we begin with calling the Browse API; the wrapper called here is just a standard routine.
Code:
Public Function SelectFolderEx(hWnd As Long, sPrompt As String, dwFlags As BF_Flags, out_Folders() As String, Optional sStartDir As String, Optional sRoot As String) As Long
'Enhanced folder chooser
Dim pidlStart As Long
Dim pidlRoot As Long
Dim lpRes As Long, szRes As String
ReDim out_Folders(0)
If sStartDir <> "" Then
pidlStart = ILCreateFromPathW(StrPtr(sStartDir))
End If
If sRoot <> "" Then
pidlRoot = ILCreateFromPathW(StrPtr(sRoot))
End If
lpRes = BrowseDialogEx(hWnd, sPrompt, dwFlags, pidlRoot, pidlStart)
If lpRes = 0 Then
SelectFolderEx = -1
Exit Function
End If
szRes = GetPathFromPIDLW(lpRes)
If (szRes = "") Or (szRes = vbNullChar) Then
'here's where we do some magic. if GetPathFromPIDLW returned nothing, but we did receive
'a valid pidl, we may have a location that still might be valid. at this time, i've made
'functions that will return the paths for the Library object, any individual library,
'My Computer, and the main Network object and network paths
Dim sAPP As String 'absolute parsing path
sAPP = GetAbsoluteParsingPath(lpRes)
If (Left$(sAPP, 2) = "\\") Or (Left$(sAPP, 2) = "//") Then
'network locations can't be resolved as normal, but are valid locations
'for most things you'll be passing a folder location to, including FindFirstFile
'the only caveat here, is the network pc itself resolves here but can't be passed
'so we want it enumed too, but not past that
Dim sTMP As String
sTMP = Mid$(sAPP, 3)
If (InStr(sTMP, "/") = 0) And (InStr(sTMP, "\") = 0) Then
'so this should be a top-level computer needing to be enum'd
SelectFolderEx = EnumSpecialObjectPaths(sAPP, out_Folders)
GoTo cfdone
End If
out_Folders(0) = sAPP
SelectFolderEx = 1
GoTo cfdone
End If
SelectFolderEx = EnumSpecialObjectPaths(sAPP, out_Folders)
Else
out_Folders(0) = szRes
SelectFolderEx = 1
End If
cfdone:
Call CoTaskMemFree(lpRes)
End FunctionThe next step is to see which, if any, object we can enumerate:
Code:
Public Function EnumSpecialObjectPaths(szID As String, sPaths() As String) As Long
'objects like Libraries and My Computer can't be passed to a file search algorithm
'but they contain objects which can. this function enumerates the searchable paths
'return value is the count of sPaths, or -1 if the GUID was not an enumerable loc
Debug.Print "esop enter " & szID
If szID = FolderGUID_Computer Then
'here we can just use the GetLogicalDriveStrings API
Dim sBuff As String * 255
Dim i As Long
i = GetLogicalDriveStrings(255, sBuff)
sPaths = Split(Left$(sBuff, i - 1), Chr$(0))
ElseIf (szID = FolderGUID_Libraries) Then 'library master
ListAllLibraryPaths sPaths
ElseIf (Left$(szID, 41) = FolderGUID_Libraries & "\") Then 'specific library
ListLibraryPaths szID, sPaths
ElseIf (szID = FolderGUID_Network) Then 'Network master
ListNetworkLocs sPaths
ElseIf (Left$(szID, 2) = "\\") Then
ListNetComputerLocs szID, sPaths
Else 'not supported or not file system
EnumSpecialObjectPaths = -1
Exit Function
End If
EnumSpecialObjectPaths = UBound(sPaths) + 1
End FunctionFor the rest, we need a more complex enumerator. This is made possible by the fact IShellItem can represent anything, and can enumerate anything, not just normal folders.
There's 2 Library options; if an individual library is selected, that's still not a normal path so has to be handled here- the IShellLibrary interface can tell us which folders are included in the library, so we can go from there. The other is for the main 'Libraries' object being selected- there we get a list of all the libraries on the system (note that we can't just check the standard ones, because custom libraries can be created).
If the Network object is chosen, we filter it down to browseable network paths, since the enum also returns the various non-computer objects that appear there.
Code:
Public Sub ListAllLibraryPaths(sOut() As String)
'Lists all paths in all libraries
Dim psi As IShellItem
Dim piesi As IEnumShellItems
Dim psiLib As IShellItem
Dim isia As IShellItemArray
Dim pLibEnum As IEnumShellItems
Dim pLibChild As IShellItem
Dim lpPath As Long
Dim szPath As String
Dim pLib As ShellLibrary
Set pLib = New ShellLibrary
Dim nPaths As Long
Dim pclt As Long
ReDim sOut(0)
Call SHCreateItemFromParsingName(StrPtr(FolderGUID_Libraries), ByVal 0&, IID_IShellItem, psi)
If (psi Is Nothing) Then
Debug.Print "could't parse lib master"
Exit Sub
End If
psi.BindToHandler 0, BHID_EnumItems, IID_IEnumShellItems, piesi
Do While (piesi.Next(1, psiLib, pclt) = S_OK)
psiLib.GetDisplayName SIGDN_NORMALDISPLAY, lpPath
szPath = LPWSTRtoStr(lpPath)
Debug.Print "Enumerating Library " & szPath
pLib.LoadLibraryFromItem psiLib, STGM_READ
pLib.GetFolders LFF_ALLITEMS, IID_IShellItemArray, isia
isia.EnumItems pLibEnum
Do While (pLibEnum.Next(1, pLibChild, 0) = 0)
pLibChild.GetDisplayName SIGDN_FILESYSPATH, lpPath
szPath = LPWSTRtoStr(lpPath, True)
Debug.Print "lib folder->" & szPath
If Len(szPath) > 2 Then
ReDim Preserve sOut(nPaths)
sOut(nPaths) = szPath
nPaths = nPaths + 1
End If
Set pLibChild = Nothing
Loop
Set psiLib = Nothing
Loop
End Sub
Public Sub ListLibraryPaths(sPN As String, sOut() As String)
'list the paths of a single library
'sPN is the full parsing name- what is returned from ishellfolder.getdisplayname(SHGDN_FORPARSING)
Dim psiLib As IShellItem
Dim pLib As ShellLibrary
Set pLib = New ShellLibrary
Dim psia As IShellItemArray
Dim pEnum As IEnumShellItems
Dim psiChild As IShellItem
Dim lpPath As Long, szPath As String, nPaths As Long
Dim pclt As Long
Call SHCreateItemFromParsingName(StrPtr(sPN), ByVal 0&, IID_IShellItem, psiLib)
If (psiLib Is Nothing) Then
Debug.Print "Failed to load library item"
Exit Sub
End If
pLib.LoadLibraryFromItem psiLib, STGM_READ
pLib.GetFolders LFF_ALLITEMS, IID_IShellItemArray, psia
If (psia Is Nothing) Then
Debug.Print "Failed to enumerate library"
Exit Sub
End If
ReDim sOut(0)
psia.EnumItems pEnum
Do While (pEnum.Next(1, psiChild, pclt) = S_OK)
If (psiChild Is Nothing) = False Then
psiChild.GetDisplayName SIGDN_FILESYSPATH, lpPath
szPath = LPWSTRtoStr(lpPath)
If Len(szPath) > 2 Then
ReDim Preserve sOut(nPaths)
sOut(nPaths) = szPath
nPaths = nPaths + 1
End If
End If
Set psiChild = Nothing
Loop
Set pEnum = Nothing
Set psia = Nothing
Set pLib = Nothing
Set psiLib = Nothing
End Sub
Public Sub ListNetworkLocs(sOut() As String) '
Dim psi As IShellItem
Dim piesi As IEnumShellItems
Dim psiNet As IShellItem
Dim isia As IShellItemArray
Dim pNetEnum As IEnumShellItems
Dim pNetChild As IShellItem
Dim lpPath As Long
Dim szPath As String
Dim nPaths As Long
Dim pclt As Long
Call SHCreateItemFromParsingName(StrPtr(FolderGUID_Network), ByVal 0&, IID_IShellItem, psi)
If psi Is Nothing Then Exit Sub
ReDim sOut(0)
psi.BindToHandler 0, BHID_EnumItems, IID_IEnumShellItems, piesi
Do While (piesi.Next(1, pNetChild, pclt) = S_OK)
pNetChild.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lpPath
szPath = LPWSTRtoStr(lpPath)
If (Left$(szPath, 2) = "//") Or (Left$(szPath, 2) = "\\") Then 'objects besides valid paths come up, like routers, devices, etc
'but they don't start with //, only searchable network locations should
Debug.Print "netpath " & szPath
ReDim Preserve sOut(nPaths)
sOut(nPaths) = szPath
nPaths = nPaths + 1
End If
Set pNetChild = Nothing
Loop
Set piesi = Nothing
Set psi = Nothing
End Sub
Public Sub ListNetComputerLocs(szID As String, sOut() As String)
'lists an individual network computer
Dim psiComp As IShellItem
Dim pEnum As IEnumShellItems
Dim psiChild As IShellItem
Dim lpPath As Long
Dim szPath As String
Dim nPaths As Long
Dim pclt As Long
Debug.Print "ListNetComputerLocs " & szID
Call SHCreateItemFromParsingName(StrPtr(szID), ByVal 0&, IID_IShellItem, psiComp)
If psiComp Is Nothing Then Exit Sub
ReDim sOut(0)
psiComp.BindToHandler 0, BHID_EnumItems, IID_IEnumShellItems, pEnum
Do While (pEnum.Next(1, psiChild, pclt) = S_OK)
psiChild.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lpPath
szPath = LPWSTRtoStr(lpPath)
If Len(szPath) > 2 Then
Debug.Print "netpath " & szPath
ReDim Preserve sOut(nPaths)
sOut(nPaths) = szPath
nPaths = nPaths + 1
End If
Loop
End SubEverything there is designed to support Unicode; but the VB textbox in the sample can't display it. But if you pass the results to something Unicode enabled, like a TextBoxW for example, you'll see the correct names.