Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1221
  • Last Modified:

Open Folder Dialog - setting initial directory

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.
  • 2
1 Solution
BrianBeckAuthor Commented:
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.
'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


BrianBeckAuthor Commented:
Thanks danaseaman

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

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now