home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD8755882000.psc / modBrowseForFolder.bas < prev    next >
Encoding:
BASIC Source File  |  2000-07-07  |  2.8 KB  |  74 lines
  1. Attribute VB_Name = "modBrowseForFolder"
  2.  
  3. 'Browse For Folder API Call Version 1.1, By Max Raskin 21 June 2000
  4.  
  5. Enum BrowseForFolderFlags
  6.     ReturnFileSystemFoldersOnly = &H1
  7.     DontGoBelowDomain = &H2
  8.     IncludeStatusText = &H4
  9.     BrowseForComputer = &H1000
  10.     BrowseForPrinter = &H2000
  11.     BrowseIncludeFiles = &H4000
  12.     IncludeTextBox = &H10
  13.     ReturnFileSystemAncestors = &H8
  14. End Enum
  15.  
  16. 'BrowseInfo is a type used with the SHBrowseForFolder API call
  17. Private Type BrowseInfo
  18.      hwndOwner As Long
  19.      pidlroot As Long
  20.      pszDisplayName As Long
  21.      lpszTitle As Long
  22.      ulFlags As Long
  23.      lpfnCallback As Long
  24.      lParam As Long
  25.      iImage As Long
  26. End Type
  27.  
  28. Dim pidlroot As Long
  29. 'SHBrowseForFolder - Gets the Browse For Folder Dialog
  30. 'SHGetPathFromIDList - Converts ID List (pidl) to String
  31.  
  32. Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
  33. Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
  34. Private Declare Function SHGetFolderLocation Lib "shell32" (hwnd As Long, nFolder As Long, hToken As Long, dwReserved As Long, ppidl As Long) As Long
  35.  
  36. 'lstrcat API function appends a string to another - that means that some API functions
  37. 'need their string in the numeric way like this does, so its kind of converts strings
  38. 'to numbers
  39. Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
  40. Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
  41.  
  42. Public Function BrowseForFolder(hwnd As Long, Optional Title As String, Optional Flags As BrowseForFolderFlags) As String
  43.  
  44.     'Variables for use:
  45.      Dim iNull As Integer
  46.      Dim IDList As Long
  47.      Dim Result As Long
  48.      Dim Path As String
  49.      Dim bi As BrowseInfo
  50.      If Flags = 0 Then Flags = BIF_RETURNONLYFSDIRS
  51.      
  52.     'Type Settings
  53.      With bi
  54.         .hwndOwner = hwndOwner 'Set Owner Window
  55.         .ulFlags = Flags 'Set flags (if any)
  56.         .lpszTitle = lstrcat(Title, Chr(0)) 'Append title string to a long value
  57.      End With
  58.  
  59.     'Execute the BrowseForFolder shell API and display the dialog
  60.      IDList = SHBrowseForFolder(bi) 'Return ID List (selected path in a long value)
  61.      
  62.     'Get the info out of the dialog
  63.      If IDList Then
  64.         Path = String$(300, 0)
  65.         Result = SHGetPathFromIDList(IDList, Path) 'Convert ID list to a string
  66.         iNull = InStr(Path, vbNullChar) 'Get the position of the null character
  67.         If iNull Then Path = Left$(Path, iNull - 1) 'Remove the null character
  68.      End If
  69.  
  70.     'If Cancel button was clicked, error occured or Non File System Folder was selected then Path = ""
  71.      BrowseForFolder = Path
  72. End Function
  73.  
  74.