folder browser control

hopskeps
hopskeps used Ask the Experts™
on
Hi all,

Who knows (has?) a suitable folder browser control that permits to create and choose folders.

Thanks a lot
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Private Const OFN_EXPLORER = &H80000             ' new look commdlg
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    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 Long
    lpTemplateName As String
End Type
Private Declare Function GetOpenFileNamePreview Lib "msvfw32.dll" (ByRef lpofn As OPENFILENAME) As Long
Private Declare Function GetSaveFileNamePreview Lib "msvfw32.dll" Alias "GetSaveFileNamePreviewA" (ByRef lpofn As OPENFILENAME) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Sub Form_Load()
    'KPD-Team 2000
    'URL: http://www.allapi.net/
    'E-Mail: KPDTeam@allapi.net
    Dim OFN As OPENFILENAME, Ret As Long
    With OFN
        .lStructSize = Len(OFN)
        .hInstance = App.hInstance
        .hwndOwner = Me.hWnd
        .lpstrTitle = "Open a file"
        .lpstrFilter = "AVI file (*.avi)" + Chr$(0) + "*.avi" + Chr$(0) + "All files (*.*)" + Chr$(0) + "*.*"
        .lpstrFile = String(255, 0)
        .nMaxFile = 255
        .flags = OFN_EXPLORER
    End With
    Ret = GetOpenFileNamePreview(OFN)
    If Ret <> 0 Then
        CloseHandle Ret
        MsgBox "The file you chose was " + Left$(OFN.lpstrFile, InStr(1, OFN.lpstrFile, Chr$(0)) - 1)
    End If
    OFN.lpstrTitle = "Save a file"
    Ret = GetSaveFileNamePreview(OFN)
    If Ret <> 0 Then
        CloseHandle Ret
        MsgBox "The file you chose was " + Left$(OFN.lpstrFile, InStr(1, OFN.lpstrFile, Chr$(0)) - 1)
    End If
End Sub


Author

Commented:
Thank you but what this code is for a file chooser. What I need is a folder-only browser that permits to create dirs.

Commented:
Why use Win32 API when VB provides you with one similar?!

selec Microsoft Common Dialog Control in Project->Components under 'Controls'-tab and add it to Form

call this for example:


Private Sub Form_Load()
    Form1.CommonDialog1.ShowOpen    
End Sub

One single call, could it be easier? You can of course set file pattern, dir and all other stuff too. Press F1 in VB after you write ShowOpen.
Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Following allows folder section but no create new folder.

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
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Sub Form_Load()
    'KPD-Team 1998
    'URL: http://www.allapi.net/
    'KPDTeam@Allapi.net
    Dim iNull As Integer, lpIDList As Long, lResult As Long
    Dim sPath As String, udtBI As BrowseInfo

    With udtBI
        'Set the owner window
        .hWndOwner = Me.hWnd
        'lstrcat appends the two strings and returns the memory address
        .lpszTitle = lstrcat("C:\", "")
        'Return only if the user selected a directory
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With

    'Show the 'Browse for folder' dialog
    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        'Get the path from the IDList
        SHGetPathFromIDList lpIDList, sPath
        'free the block of memory
        CoTaskMemFree lpIDList
        iNull = InStr(sPath, vbNullChar)
        If iNull Then
            sPath = Left$(sPath, iNull - 1)
        End If
    End If

    MsgBox sPath
End Sub

Software Team Lead
Commented:
Here is it:

Public Const BIF_RETURNONLYFSDIRS = &H1      'Only file system directories
Public Const BIF_DONTGOBELOWDOMAIN = &H2     'No network folders below domain level
Public Const BIF_STATUSTEXT = &H4            'Includes status area in the dialog (for callback)
Public Const BIF_RETURNFSANCESTORS = &H8     'Only returns file system ancestors
Public Const BIF_EDITBOX = &H10              'Allows user to rename selection
Public Const BIF_VALIDATE = &H20             'Insist on valid edit box result (or CANCEL)
Public Const BIF_USENEWUI = &H40             'Version 5.0. Use the new user-interface.
                                             'Setting this flag provides the user with
                                             'a larger dialog box that can be resized.
                                             'It has several new capabilities including:
                                             'dialog box, reordering, context menus, new
                                             'folders, drag and drop capability within
                                             'the delete, and other context menu commands.
                                             'To use you must call OleInitialize or
                                             'CoInitialize before calling SHBrowseForFolder.
Public Const BIF_BROWSEFORCOMPUTER = &H1000  'Only returns computers.
Public Const BIF_BROWSEFORPRINTER = &H2000   'Only returns printers.
Public Const BIF_BROWSEINCLUDEFILES = &H4000 'Browse for everything

Public Const WM_USER = &H400
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100) 'BFFM_SETSTATUSTEXT
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102) 'BFFM_SETSELECTION
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)

Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SELCHANGED = 2
'public Const MAX_PATH = 260

Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

Public Const BM_GETCHECK = &HF0
Public Const BM_GETSTATE = &HF2
Public Const BM_SETCHECK = &HF1
Public Const BM_SETSTATE = &HF3
Public Const BM_SETSTYLE = &HF4

Public Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Public Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" (ByVal szPath As String) As Long

Public Type BrowseInfo
   hwndOwner      As Long
   pIDLRoot       As Long
   pszDisplayName As String
   lpszTitle      As String
   ulFlags        As Long
   lpfnCallback   As Long
   lParam         As Long
   iImage         As Long
End Type

Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

Public m_CurrentDirectory As String

'!Is Directory Exist?
'<Note>: Requires Windows 2000 (or Windows NT 4.0 with Internet Explorer 4.0 or later);
'        Requires Windows 98 (or Windows 95 with Internet Explorer 4.0 or later)
Public Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long

Public Function isDirExist(ByVal dir As String) As Boolean
    isDirExist = CBool(PathFileExists(dir))
End Function

Public Function BrowseFolderByPath(ByRef frm As Form, Optional odtvTitle As String = "Select a directory", Optional sSelPath As String = "", Optional RootDirIsSelPath As Boolean = False, Optional ShowNewFolderButton As Boolean = False, Optional ShowStatusText As Boolean = False, Optional ShowTextBox As Boolean = False, Optional BrowseIncludeFiles As Boolean = False) As String

    Dim BI As BrowseInfo
    Dim pidl As Long
    Dim lpSelPath As Long
    Dim sPath As String * MAX_PATH
    Dim mflags As Long
    Dim RootDir As Long
   
    m_CurrentDirectory = sSelPath & vbNullString
   
    mflags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
    'Display New Folder Button
    If ShowNewFolderButton Then mflags = mflags + 64
   
    'Display Status Text
    If ShowStatusText Then mflags = mflags + BIF_STATUSTEXT + BIF_VALIDATE
   
    'Display Text Box
    If ShowTextBox Then mflags = mflags + 16
   
    'Display Files
    If BrowseIncludeFiles Then mflags = mflags + BIF_BROWSEINCLUDEFILES
   
    If RootDirIsSelPath = True Then RootDir = GetPIDLFromPath(sSelPath)
   
    With BI
        .hwndOwner = frm.hwnd
        .lpszTitle = odtvTitle
        '.lpszTitle = lstrcat(odtvTitle, "")
        .ulFlags = mflags
       
        If isDirExist(sSelPath) = True Then
            .pIDLRoot = RootDir
           
            lpSelPath = LocalAlloc(LPTR, Len(sSelPath) + 1)
            CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
            .lParam = lpSelPath
            .lpfnCallback = FARPROC(AddressOf BrowseCallbackProcStr)
        End If
    End With
   
    pidl = SHBrowseForFolder(BI)
   
    If pidl Then
     
        If SHGetPathFromIDList(pidl, sPath) Then
           BrowseFolderByPath = Left$(sPath, InStr(sPath, vbNullChar) - 1)
        End If
     
        Call CoTaskMemFree(pidl)
   
    End If
   
    Call LocalFree(lpSelPath)

End Function

Public Function BrowseFolderByPIDL(ByRef frm As Form, Optional odtvTitle As String = "Select a directory", Optional sSelPath As String = "", Optional RootDirIsSelPath As Boolean = False, Optional ShowNewFolderButton As Boolean = False, Optional ShowStatusText As Boolean = False, Optional ShowTextBox As Boolean = False, Optional BrowseIncludeFiles As Boolean = False) As String

    Dim BI As BrowseInfo
    Dim pidl As Long
    Dim lpSelPath As Long
    Dim sPath As String * MAX_PATH
    Dim mflags As Long
    Dim RootDir As Long
   
    mflags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
    'Display New Folder Button
    If ShowNewFolderButton Then mflags = mflags + 64
   
    'Display Status Text
    If ShowStatusText Then mflags = mflags + BIF_STATUSTEXT + BIF_VALIDATE
   
    'Display Text Box
    If ShowTextBox Then mflags = mflags + 16
   
    'Display Files
    If BrowseIncludeFiles Then mflags = mflags + BIF_BROWSEINCLUDEFILES
   
    If RootDirIsSelPath = True Then RootDir = GetPIDLFromPath(sSelPath)
   
    With BI
        .hwndOwner = frm.hwnd
        .lpszTitle = odtvTitle
        .lpfnCallback = FARPROC(AddressOf BrowseCallbackProc)
        .ulFlags = mflags
       
        If isDirExist(sSelPath) = True Then
            .pIDLRoot = RootDir
           
            lpSelPath = GetPIDLFromPath(sSelPath)
            CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
            .lParam = lpSelPath
            .lpfnCallback = FARPROC(AddressOf BrowseCallbackProcStr)
        End If
       
    End With
   
    pidl = SHBrowseForFolder(BI)
   
    If pidl Then
        If SHGetPathFromIDList(pidl, sPath) Then
            BrowseFolderByPIDL = Left$(sPath, InStr(sPath, vbNullChar) - 1)
        End If
     
        'free the pidl returned by call to SHBrowseForFolder
        Call CoTaskMemFree(pidl)
    End If
   
    'free the pidl set in call to GetPIDLFromPath
    Call CoTaskMemFree(BI.lParam)
     
End Function

Public Function GetPIDLFromPath(sPath As String) As Long

  'return the pidl to the path supplied by calling the
  'undocumented API #162 (our name SHSimpleIDListFromPath).
  'This function is necessary as, unlike documented APIs,
  'the API is not implemented in 'A' or 'W' versions.

  If IsWinNT Then
    GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(sPath, vbUnicode))
  Else
    GetPIDLFromPath = SHSimpleIDListFromPath(sPath)
  End If

End Function

Public Function BrowseCallbackProc(ByVal hwnd As Long, _
                                   ByVal uMsg As Long, _
                                   ByVal lParam As Long, _
                                   ByVal lpData As Long) As Long
 
  On Error Resume Next
 
  Dim lpIDList As Long
  Dim ret As Long
  Dim sBuffer As String
 
  'Callback for the Browse PIDL method.
 
  'On initialization, set the dialog's
  'pre-selected folder using the pidl
  'set as the bi.lParam, and passed back
  'to the callback as lpData param.
   Select Case uMsg
      Case BFFM_INITIALIZED
     
         Call SendMessage(hwnd, BFFM_SETSELECTIONA, _
                          False, ByVal lpData)
                         
      Case BFFM_SELCHANGED
            'sBuffer = Space(MAX_PATH)
            '
            'ret = SHGetPathFromIDList(lParam, sBuffer)
            'If ret = 1 Then
            '  Call SendMessage(hwnd, BFFM_SETSTATUSTEXTA, 0, sBuffer)
            'End If
      Case Else:
         
   End Select

End Function

Public Function BrowseCallbackProcStr(ByVal hwnd As Long, _
                                      ByVal uMsg As Long, _
                                      ByVal lParam As Long, _
                                      ByVal lpData As Long) As Long
                                       
  On Error Resume Next
 
  Dim lpIDList As Long
  Dim ret As Long
  Dim sBuffer As String
 
  'Callback for the Browse STRING method.
 
  'On initialization, set the dialog's
  'pre-selected folder from the pointer
  'to the path allocated as bi.lParam,
  'passed back to the callback as lpData param.
 
   Select Case uMsg
      Case BFFM_INITIALIZED
     
         Call SendMessage(hwnd, BFFM_SETSELECTIONA, _
                          True, ByVal lpData)
                         
      Case BFFM_SELCHANGED
            'sBuffer = Space(MAX_PATH)
           
            'ret = SHGetPathFromIDList(lParam, sBuffer)
            'If ret = 1 Then
            '  Call SendMessage(hwnd, BFFM_SETSTATUSTEXTA, 0, sBuffer)
            'End If
      Case Else:
         
   End Select
     
End Function

Public Function FARPROC(pfn As Long) As Long
 
  'A dummy procedure that receives and returns
  'the value of the AddressOf operator.
 
  'This workaround is needed as you can't assign
  'AddressOf directly to a member of a user-
  'defined type, but you can assign it to another
  'long and use that (as returned here)
  FARPROC = pfn

End Function

* Apology if the long post, but hope this will helps
Ryan ChongSoftware Team Lead

Commented:
Try it like:

Private Sub Command3_Click()
    Dim tmp As String
    tmp = BrowseFolderByPath(Me, , CurDir, , True)
    MsgBox tmp
End Sub

cheers

Author

Commented:
Thanks to all of you for your help.

ryancis it works fine!!
Just before closing this post, do you know if your solution has specific platform requirements ? Does it work with Win 98 ?
Dirk HaestProject manager

Commented:
Normally it should work on every operating system of microsoft (win 95-win98,win 2000,win xp) if you've installed all the necessary vb-components.
Apparantly for this you haven't to install something extra

Author

Commented:
thanks a lot Dhaest.

I woud be very grateful if you can give an answer to this question too :))

Author

Commented:
Help ryancis

your code seems incomplete. functions like SendMessage or isWinnt are not given in your post :((
Ryan ChongSoftware Team Lead

Commented:
Opps, here is it:

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Function IsWinNT() As Boolean
    IsWinNT = CBool(Len(Environ$("OS")))
End Function

Author

Commented:
great !!
thanks
Ryan ChongSoftware Team Lead

Commented:
Glad could make help :) cheers

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial