Solved

Open Folder Dialog - setting initial directory

Posted on 2006-11-28
3
1,195 Views
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_RETURNONLYFSDIRS = &H1
Const BIF_EDITBOX = &H10
Const BIF_DONTGOBELOWDOMAIN = &H2
    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.
0
Comment
Question by:BrianBeck
  • 2
3 Comments
 

Author Comment

by:BrianBeck
Comment Utility
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.
0
 
LVL 22

Accepted Solution

by:
danaseaman earned 400 total points
Comment Utility
'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, _
      BIF_BROWSEINCLUDEFILES Or BIF_STATUSTEXT Or BIF_USENEWUI, _
      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

Private Type BROWSEINFOA
   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_RETURNFSANCESTORS = &H8
   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_USENEWUI = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
   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
   m_bNewUI = (ulFlags And BIF_NEWDIALOGSTYLE) = BIF_NEWDIALOGSTYLE

   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))
      Else
         .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
      Case BFFM_INITIALIZED
         SendMessage hWnd, BFFM_SETSELECTIONA, 1, m_StartDir
         SetWindowTextA hWnd, m_DialogTitle

      Case BFFM_SELCHANGED
         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

'----------------------

0
 

Author Comment

by:BrianBeck
Comment Utility
Thanks danaseaman

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

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

I’ve seen a number of people looking for examples of how to access web services from VB6.  I’ve been using a test harness I built in VB6 (using many resources I found online) that I use for small projects to work out how to communicate with web serv…
Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

743 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

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now