Open Folder Dialog - setting initial directory

Posted on 2006-11-28
Last Modified: 2013-12-26
Hi Gurus

I've been using the following code (found months ago on EE) to open a "set folder" dialog:

Const BIF_EDITBOX = &H10
    Const procname As String = "btn_UpdateFolder_Click"
     On Error GoTo Err

        Dim oShell As Object
        Dim sPath As String
        Set oShell = CreateObject("Shell.Application")
        On Error Resume Next
        sPath = oShell.BrowseForFolder(hwnd, "Select folder for AQ database", BIF_RETURNONLYFSDIRS Or BIF_EDITBOX).Items.item.Path
        If sPath = "" Then sPath = "Nothing"
        'MsgBox "You select " & sPath & " from folder dialog.", vbInformation, "Browse for folders"
        txt_Database_Path = sPath
        'save to registry
         SaveSetting App.Title, "Settings", "mdb_FolderPath", sPath
        Set oShell = Nothing
        Exit Sub

While the above does the job, it become rather tiresome for users who have to navigate several sub-folders to get to the one they need.  I've tried various ways of setting the initial directory and am keen to succeed -your help is most appreciated.
Question by:BrianBeck
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2

Author Comment

ID: 18026764
What I mean by trying includes:
sPath = oShell.BrowseForFolder(hwnd, "Select AQ GNAF database Folder", BIF_RETURNONLYFSDIRS, InitialFolder).Self.Path

However, the above wakes up at the Desktop level, even when I've set the InitialFolder variable to somewhere obviously different.

I've increased points due to urgency.
LVL 22

Accepted Solution

danaseaman earned 400 total points
ID: 18026981
'In Form:>

Option Explicit

Dim m_sFolder           As String 'Path of Folder/File returned from BrowseForFolder dialog.
Dim m_sDisplayName      As String 'Item text returned from BrowseForFolder dialog.

Private Sub cmdBrowse_Click()
   Dim sFolder          As String

   m_sFolder = "D:\"

   sFolder = Browse(Me.hWnd, _
      m_sFolder, _
      m_sDisplayName, _
      "Title:", _
      "Dialog Title: ", _

   Debug.Print sFolder & vbCrLf & _
      "DisplayName: " & m_sDisplayName

End Sub

'In Module:

Option Explicit

Private Const WM_USER   As Long = &H400&

' message from browser
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)

Private Const MAX_PATH  As Long = 260

   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

Public Enum bif
   BIF_RETURNONLYFSDIRS = &H1        ' For finding a folder to start document searching
   BIF_DONTGOBELOWDOMAIN = &H2       ' For starting the Find Computer
   BIF_STATUSTEXT = &H4              ' Top of the dialog has 2 lines of text for BROWSEINFO.lpszTitle and one line if
   ' this flag is set.  Passing the message BFFM_SETSTATUSTEXTA to the hwnd can set the
   ' rest of the text.  This is not used with BIF_USENEWUI and BROWSEINFO.lpszTitle gets
   ' all three lines of text.
   BIF_EDITBOX = &H10                ' Add an editbox to the dialog
   BIF_VALIDATE = &H20               ' insist on valid result (or CANCEL)

   BIF_NEWDIALOGSTYLE = &H40         ' Use the new dialog layout with the ability to resize
   ' Caller needs to call OleInitialize() before using this API

   BIF_BROWSEINCLUDEURLS = &H80      ' Allow URLs to be displayed or entered. (Requires BIF_USENEWUI)
   BIF_UAHINT = &H100                ' Add a UA hint to the dialog, in place of the edit box. May not be combined with BIF_EDITBOX
   BIF_NONEWFOLDERBUTTON = &H200     ' Do not add the "New Folder" button to the dialog.  Only applicable with BIF_NEWDIALOGSTYLE.
   BIF_NOTRANSLATETARGETS = &H400    ' don't traverse target as shortcut
   BIF_BROWSEFORCOMPUTER = &H1000    ' Browsing for Computers.
   BIF_BROWSEFORPRINTER = &H2000     ' Browsing for Printers
   BIF_BROWSEINCLUDEFILES = &H4000   ' Browsing for Everything
   BIF_SHAREABLE = &H8000            ' sharable resources displayed (remote shares, requires BIF_USENEWUI)
End Enum

Private Declare Function SHBrowseForFolderA Lib "shell32" (lpBrowseInfo As BROWSEINFOA) As Long
Private Declare Function SHGetIDListFromPath Lib "shell32" Alias "#162" (ByVal szPath As String) As Long
Private Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SetWindowTextA Lib "User32" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)

Private Buffer          As String * MAX_PATH
Private m_DialogTitle   As String

Private m_StartDir      As String
Private m_bNewUI        As Boolean

Public Function Browse(ByVal hWnd As Long, Optional ulFlags As bif = BIF_RETURNONLYFSDIRS, Optional ByVal sStartDir As String, Optional ByRef sDisplayName As String, Optional ByVal sTitle As String, Optional ByVal sDialogTitle As String, Optional ByVal sRootDir As String) As String

   Dim biA              As BROWSEINFOA
   Dim pidl             As Long

   m_StartDir = sStartDir
   m_DialogTitle = sDialogTitle

   With biA 'Fill the BROWSEINFO structure.
      .hOwner = hWnd  'GetDesktopWindow() 'can be application or Desktop hwnd

      If LenB(sRootDir) Then 'get pidl of root folder
         .pidlRoot = SHGetIDListFromPath(StrConv(sRootDir, vbUnicode))
         .pidlRoot = 0& 'desktop folder is used
      End If

      .pszDisplayName = Buffer     'Display Name

      If LenB(sTitle) Then
         .lpszTitle = sTitle   'Title text
      End If

      .ulFlags = ulFlags 'dialog type.

      .lpfn = GetAddressofFunction(AddressOf BrowseCallbackProc) 'Callback
   End With

   pidl = SHBrowseForFolderA(biA)  'show the dialog
   sDisplayName = StripNull(biA.pszDisplayName)

   Browse = SHGetPathFromIDList(pidl, Buffer)

End Function

Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
   Dim sBuffer          As String

   On Error Resume Next  'Suggested by MS to prevent an error from
   'propagating back into the calling process.

   Select Case uMsg
         SendMessage hWnd, BFFM_SETSELECTIONA, 1, m_StartDir
         SetWindowTextA hWnd, m_DialogTitle

         sBuffer = Space$(MAX_PATH)

         If SHGetPathFromIDListA(ByVal lp, sBuffer) = 1 Then
            Call SendMessage(hWnd, BFFM_SETSTATUSTEXTA, 0, sBuffer)
         End If

   End Select

   BrowseCallbackProc = 0

End Function

' This function allows you to assign a function pointer to a vaiable.
Private Function GetAddressofFunction(add As Long) As Long
   GetAddressofFunction = add
End Function

Private Function SHGetPathFromIDList(ByVal pidl As Long, ByVal pszPath As String) As String
   If pidl = 0 Then Exit Function

   If SHGetPathFromIDListA(ByVal pidl, pszPath) Then
      SHGetPathFromIDList = StripNull(pszPath)
   End If

   CoTaskMemFree pidl

End Function

Private Function StripNull(ByVal StrIn As String) As String
   Dim nul              As Long
   ' Truncate input string at first null.
   ' If no nulls, perform ordinary Trim.
   nul = InStr(1, StrIn, vbNullChar, vbBinaryCompare)
   Select Case nul
      Case Is > 1
         StripNull = Left$(StrIn, nul - 1)
      Case 1
         StripNull = ""
      Case 0
         StripNull = Trim$(StrIn)
   End Select
End Function



Author Comment

ID: 18027042
Thanks danaseaman

It looks quite intricate - the main point is that it works!

Featured Post

Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Add a task in Outlook from access 11 43
Passing a Text Box name to a Sub 6 104
vbModal 12 75
odbc driver manager data source name not found and no default driver specified 9 64
Introduction While answering a recent question ( in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
Article by: Martin
Here are a few simple, working, games that you can use as-is or as the basis for your own games. Tic-Tac-Toe This is one of the simplest of all games.   The game allows for a choice of who goes first and keeps track of the number of wins for…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

738 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question