GFCDSelectDirectory/Mfrm.frm

VERSION 5.00
Begin VB.Form Mfrm
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.CommandButton Command1
      Caption         =   "Select Directory"
      Height          =   375
      Left            =   2580
      TabIndex        =   0
      Top             =   2700
      Width           =   1935
   End
End
Attribute VB_Name = "Mfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis. Belongs to the GFCD functions (GFCDSelectColor, GFCD[Load/Save]File(), GFCDSelectDirectory).
'NOTE: for selecting a directory ('folder') one cannot use
'the common dialog controls, but API functions only.
'The source of the declarations is (04‑28‑2001):
'http://www.powerup.com.au/~dagwood/fileio.htm
'(good site).
'GFSelectDirectory
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
'GFSelectDirectory
Private Type BROWSEINFO
   hOwner As Long
   pidlRoot As Long
   pszDisplayName As String
   lpszTitle As String
   ulFlags As Long
   lpfn As Long
   lParam As Long
   iImage As Long
End Type
'GFSelectDirectory
Private Const MAX_PATH = 260
Private Const ERROR_SUCCESS As Long = 0
Private Const CSIDL_DESKTOP As Long = &H0
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_STATUSTEXT As Long = &H4
Private Const BIF_RETURNFSANCESTORS As Long = &H8

Private Sub Command1_Click()
    'on error resume next
    Debug.Print GFSelectDirectory("c:\mp3\", "Test")
End Sub

Private Function GFSelectDirectory(ByVal RootDirectory As String, ByVal InfoText As String) As String
    On Error Resume Next 'v1.0 ‑ does not support a root directory
    Dim BROWSEINFOVar As BROWSEINFO
    Dim Temp As Long
    Dim Tempstr$
    'preset
    'BROWSEINFOVar.pidlRoot = RootDirectory 'does not work
    BROWSEINFOVar.hOwner = 0 'do not use an owner form (module ?)
    BROWSEINFOVar.pszDisplayName = String$(MAX_PATH, Chr$(0)) 'display name (i.e. 'Windows' for C:\Windows\)
    BROWSEINFOVar.lpszTitle = InfoText
    BROWSEINFOVar.ulFlags = BIF_RETURNONLYFSDIRS 'file system directories only
    BROWSEINFOVar.lpfn = 0 'address of event call‑back function
    BROWSEINFOVar.lParam = 0 'parameter that would be passed to event call‑back function
    'begin
    Temp = SHBrowseForFolder(BROWSEINFOVar)
    'return selected folder
    'BROWSEINFOVar.pszDisplayName 'display name of selected folder
    'BROWSEINFOVar.iImage 'image of selected item in system image list
    If Not (Temp = 0) Then 'verify
        Tempstr$ = String$(MAX_PATH, Chr$(0))
        Call SHGetPathFromIDList(ByVal Temp, ByVal Tempstr$)
        If Not (InStr(1, Tempstr$, Chr$(0), vbBinaryCompare) = 0) Then 'verify
            GFSelectDirectory = Left$(Tempstr$, InStr(1, Tempstr$, Chr$(0), vbBinaryCompare) ‑ 1) 'ok
        Else
            GFSelectDirectory = "" 'error
        End If
    Else
        GFSelectDirectory = "" 'error
    End If
End Function


[END OF FILE]