Xtreme Visual Basic Talk

Xtreme Visual Basic Talk (http://www.xtremevbtalk.com/index.php)
-   API (http://www.xtremevbtalk.com/forumdisplay.php?f=15)
-   -   SHBrowseForFolder default/root directory (http://www.xtremevbtalk.com/showthread.php?t=213821)

gubbs 03-01-2005 02:08 PM

SHBrowseForFolder default/root directory
 
Dear all,

I want to use the SHBrowseForFolder function, but would like to configure the function such that the default/root directory that the window shows is a directory of my choosing. Unfortunately, I can't figure out how to pass a default/root parameter to the SHBrowseForFolder function. Can somebody help me out? Thanx!

OnErr0r 03-01-2005 02:58 PM

Add a BrowseFolderCallback and wait for BFFM_INITIALIZED. Once received use SendMessage with BFFM_SETSELECTION to send the directory to the treeview. Make sure the directory actually exists before setting the selection.

RayOK 03-01-2005 03:27 PM

That would auto-select the start folder.. yes, but is that what he wants? If you want to set the root, then you will have to convert your path name to a pidl then specify that in the BROWSEINFO structure when you call SHBrowseForFolder. :)

OnErr0r 03-01-2005 03:37 PM

I may have mis-read the question RayOK, thanks for pointing that out. SHGetSpecialFolderLocation with the correct CLSID_X can be used to get the desired .pidlroot.

OnErr0r 03-01-2005 03:50 PM

Additionally, SHILCreateFromPath is available with 2K and up.

gubbs 03-01-2005 05:02 PM

All,

Many thanx to the prompt responses. To clarify my problem, the following is a Microsoft Excel scenario:

1. An administrator configures a default directory for users in a cell named 'strPath'. For example: "C:\analyst\chromatograms\"
2. The Excel application has a button named 'Browse'. The 'Browse' button calls a function that uses the SHBrowseForFolders function to display to user a window of directories.
3. Ideally: When a users clicks on the 'Browse' button, the Browse for Folders window is displayed to him/her in which the selected directory is the directory configured as 'strPath'.

Problem: The default selected directory displayed by SHBrowseForFolders is My Computer. I'd like to be able to configure the default selected directory. I'm most sure that the advice supplied by the respondants will work for me. Unfortunately, I'm very foggy on how to implement the suggestions. If someone were able to supply a bit of code on how to use SHILCreateFromPath or SHGetSpecialFolderLocation, that would be great. The Microsoft site has detailed descriptions of all these functions, but examples of how to actually use them seem to be sparse.

Again, I thank everyone for their responses.

RayOK 03-01-2005 08:03 PM

Ahh, so the "root" folder is where you want to start, and not the actual root like I thought. OnError was right! Again! :eek: :p Anyway, I am feeling good so I will give you everything you need :D

The below is all the declares, BROWSEINFO structure, etc to get you a browse dialog. It also includes a custom function called GetFolder()

GetFolder works by GetFolder(<title>, <path>, <show new folder>) and returns a string which is the path to the folder.
<title> is the caption displayed above the folders
<path> is the preselected folder, starting path (your cell value)
<show new folder> is a boolean which, when true will show the "Make New Folder" button.

To make this all work, copy the following to a new module:
Code:
Option Explicit Private Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _ ByVal pszPath As String) As Long Private Declare Function GetForegroundWindow Lib "user32" () As Long Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long) Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, lParam As Any) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long) Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long Private Const MAX_PATH = 260 Private Const BIF_RETURNONLYFSDIRS = 1 Private Const BIF_NEWDIALOGSTYLE = &H40 Private Const BFFM_INITIALIZED As Long = 1 Private Const BFFM_SELCHANGED As Long = 2 Private Const BFFM_VALIDATEFAILED As Long = 3 Private Const WM_USER = &H400 Private Const BFFM_SETSTATUSTEXT As Long = (WM_USER + 100) Private Const BFFM_ENABLEOK As Long = (WM_USER + 101) Private Const BFFM_SETSELECTION As Long = (WM_USER + 102) Private Const LMEM_FIXED = &H0 Private Const LMEM_ZEROINIT = &H40 Private Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT) 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 Public Function GetFolder(ByVal title As String, ByVal start As String, ByVal newfolder As Boolean) As String Dim BI As BROWSEINFO, pidl As Long, lpSelPath As Long Dim spath As String * MAX_PATH 'fill in the info it needs With BI .hOwner = GetForegroundWindow .pidlRoot = 0 .lpszTitle = title .lpfn = FARPROC(AddressOf BrowseCallbackProcStr) .ulFlags = BIF_RETURNONLYFSDIRS If newfolder = True Then .ulFlags = BIF_RETURNONLYFSDIRS + BIF_NEWDIALOGSTYLE lpSelPath = LocalAlloc(LPTR, Len(start) + 1) CopyMemory ByVal lpSelPath, ByVal start, Len(start) + 1 .lParam = lpSelPath End With 'get the idlist long from the returned folder pidl = SHBrowseForFolder(BI) 'do then if they clicked ok If pidl Then If SHGetPathFromIDList(pidl, spath) Then 'next line is the returned folder GetFolder = Left$(spath, InStr(spath, vbNullChar) - 1) End If Call CoTaskMemFree(pidl) Else 'user clicked cancel End If Call LocalFree(lpSelPath) End Function 'this seems to happen before the box comes up and when a folder is clicked on within it Public Function BrowseCallbackProcStr(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long Dim spath As String, bFlag As Long spath = Space$(MAX_PATH) Select Case uMsg Case BFFM_INITIALIZED 'browse has been initialized, set the start folder Call SendMessage(hWnd, BFFM_SETSELECTION, 1, ByVal lpData) Case BFFM_SELCHANGED If SHGetPathFromIDList(lParam, spath) Then spath = Left(spath, InStr(1, spath, Chr(0)) - 1) End If End Select End Function Public Function FARPROC(pfn As Long) As Long FARPROC = pfn End Function

Then the macro of your button on the Excel sheet would be something like:

strFolder = GetFolder("Select a folder", Sheet1.Range("A1").Value, True) where strFolder is the variable it sets, of course.

Hope all this helps! :D

OnErr0r 03-01-2005 08:13 PM

Darn.. looks like Ray beat me to the punch. :D

Here's my implementation too, since I spent a bit of time on it:

Code:
Option Explicit Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal hMem As Long) Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, lParam As Any) 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 Const BIF_RETURNONLYFSDIRS As Long = 1 Private Const CSIDL_DRIVES As Long = &H11 Private Const WM_USER As Long = &H400 Private Const MAX_PATH As Long = 260 ' Is it a bad thing that I memorized this value? '// message from browser Private Const BFFM_INITIALIZED As Long = 1 Private Const BFFM_SELCHANGED As Long = 2 Private Const BFFM_VALIDATEFAILEDA As Long = 3 '// lParam:szPath ret:1(cont),0(EndDialog) Private Const BFFM_VALIDATEFAILEDW As Long = 4 '// lParam:wzPath ret:1(cont),0(EndDialog) Private Const BFFM_IUNKNOWN As Long = 5 '// provides IUnknown to client. lParam: IUnknown* '// messages to browser Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100 Private Const BFFM_ENABLEOK As Long = WM_USER + 101 Private Const BFFM_SETSELECTIONA As Long = WM_USER + 102 Private Const BFFM_SETSELECTIONW As Long = WM_USER + 103 Private Const BFFM_SETSTATUSTEXTW As Long = WM_USER + 104 Private Const BFFM_SETOKTEXT As Long = WM_USER + 105 '// Unicode only Private Const BFFM_SETEXPANDED As Long = WM_USER + 106 '// Unicode only Private Type BrowseInfo hWndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As String ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Private Function PtrToFunction(ByVal lFcnPtr As Long) As Long PtrToFunction = lFcnPtr End Function Private Function CorrectPath(ByVal sPath As String) As String If Right$(sPath, 1) = "\" Then If Len(sPath) > 3 Then sPath = Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root Else If Len(sPath) = 2 Then sPath = sPath & "\" ' Append backslash to root End If CorrectPath = sPath End Function Private Function DirectoryExists(ByVal sDirectory As String) As Long If LenB(sDirectory) Then If GetFileAttributes(sDirectory) >= vbNormal Then DirectoryExists = True End If End If End Function Public Function FolderBrowser(ByVal sDialogTitle As String, ByVal sPath As String) As String Dim b(MAX_PATH) As Byte Dim pItem As Long Dim sFullPath As String Dim bi As BrowseInfo Dim ppidl As Long sPath = CorrectPath(sPath) bi.hwndOwner = Screen.ActiveForm.hwnd SHGetSpecialFolderLocation bi.hwndOwner, CSIDL_DRIVES, ppidl bi.pIDLRoot = ppidl bi.pszDisplayName = VarPtr(b(0)) bi.lpszTitle = sDialogTitle bi.ulFlags = BIF_RETURNONLYFSDIRS If DirectoryExists(sPath) Then bi.lpfnCallback = PtrToFunction(AddressOf BFFCallback) bi.lParam = StrPtr(sPath) pItem = SHBrowseForFolder(bi) If pItem Then ' Succeeded sFullPath = Space$(MAX_PATH) If SHGetPathFromIDList(pItem, sFullPath) Then FolderBrowser = Left$(sFullPath, InStr(sFullPath, vbNullChar) - 1) ' Strip nulls CoTaskMemFree pItem End If End If End Function ' typedef int (CALLBACK* BFFCALLBACK)(HWND hwnd, UINT uMsg, LPARAM lParam, LPARAM lpData); Public Function BFFCallback(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal sData As String) As Long If uMsg = BFFM_INITIALIZED Then SendMessage hwnd, BFFM_SETSELECTIONA, True, ByVal sData End If End Function

Code:
' Usage (in VB anyway) Private Sub Form_Load() Show ' So ActiveForm.Hwnd is initialized Debug.Print FolderBrowser("Select a directory:", App.Path) End Sub

RayOK 03-01-2005 08:31 PM

Ack! About 10 minutes is all.. ;)
And your version looks better than mine and mine is only a detailed modification of: http://vbnet.mvps.org/code/callback/browsecallback.htm

Edit: 10 minutes between our posts that is :)

gubbs 03-03-2005 07:41 AM

All,

Thanx bunch for all the help! RayOK's solution worked in my Excel app that I'm building. OnError's solution has a problem with the Callback function (get a syntax error message) when I run it in a VBA environment, but I appreciate extremely the effort. As always, this forum has provided successful valuable solutions to my problems.

OnErr0r 03-03-2005 08:09 AM

Interesting.. I'm not a VBAer, but I'm curious, which line of code has a syntax error?

gubbs 03-03-2005 08:31 AM

Onerror:

Actually, two things were of issue:

1. I had to comment out the 'bi.hWndOwner = Screen.ActiveForm.hwnd' line because I'm not using a form in Excel. RayOK used this statement: 'BI.hOwner = GetForegroundWindow' that worked.

2. When this line of code is executed:

pItem = SHBrowseForFolder(bi)

the function 'BFFCallback(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal sData As String) As Long' is called. I get the following error message:

'Compile Error: Sytax Error'

The VBA debugger then takes me to the BFFCallback function as the offending function.

I compared your callback function to RayOK's callback function. He's using BrowseCallbackProcStr rather than BFFCallback.

OnErr0r 03-03-2005 08:44 AM

I just ran mine in Word VBA and had no problem, compiled and ran (Sans Screen.ActiveForm of course). Could you have used his constants instead of mine? I'm using BFFM_SETSELECTIONA instead of BFFM_SETSELECTION. The callback function name can be anything, as long as the AddressOf the correct function is passed.

*calling a VBA expert/guru* :)

Timbo 03-03-2005 09:20 AM

What version on Office are you running? AddressOf was only introduced post-97.

Incidentally, is there a reason you're not using the 'GetOpenFilename' method of the Excel Application object?

gubbs 03-03-2005 09:52 AM

OnError:

Hmmm. I didn't try your code in Word, though it shouldn't matter. Unfortunately, I'm not going to delve too much further. I'm going to use RayOK's code and move forward. I do appreciate your effort.

Timbo:
I'm running Office 2003. I'm not using the GetOpenFileName because the intent is not to have a user select or open a file. The intent is to have a user select a directory.

OnErr0r 03-03-2005 11:33 AM

gubbs,
No problem. Timbo or one of the other VBA experts will help me figure it out. Stay tuned for a solution in any event. :)

OnErr0r 03-03-2005 05:10 PM

Ok, changes for Excel:

In the FolderBrowser Function:

Code:
'bi.hWndOwner = Screen.ActiveWindow.hwnd bi.hWndOwner = Application.hwnd In Usage: 'App.Path Application.Path

There's nothing wrong with the callback as written. My guess is you did not paste the callback function in it's entirity. VBA experts Herilane and NateO tested my code on Excel 2000, 2002 and 2003, no problems. (Many thanks to both of them) I also tested on Word 2000.


For Word, you must use API for the hwnd. Might as well go for Ray's suggestion there and use GetForegroundWindow.

Note to anyone using this in the future: Make certain you pass a valid path to the dialog (this is the purpose of my code to trim/add backslashes and ensure the directory exists), if you do not you will crash VB entirely, or make a nice runtime error in your compiled exe.

RayOK 03-03-2005 06:57 PM

That's interesting. I passed a blank string ("") as the start folder and it worked fine. Compiled too. It selected My Computer. If I passed in "c:" it selected My Documents. Weird. So, technically, all those parameters in my GetFolder() could be optional and set to some default, like so:

Code:
Public Function GetFolder(Optional ByVal title As String = "Select a folder..", _ Optional ByVal start As String = "", Optional ByVal newfolder As Boolean = True) As String

Originally I had GetFolder take in a form (ByVal form as Form) and set the ownder to the .hWnd of that, but since he was using Excel and there are no "forms" I used GetForegroundWindow instead and took that out. :D

Ivan F Moala 03-03-2005 07:50 PM

Quote:

Originally Posted by gubbs
OnError:

Hmmm. I didn't try your code in Word, though it shouldn't matter. Unfortunately, I'm not going to delve too much further. I'm going to use RayOK's code and move forward. I do appreciate your effort.

Timbo:
I'm running Office 2003. I'm not using the GetOpenFileName because the intent is not to have a user select or open a file. The intent is to have a user select a directory.

There are a number of ways to do this (Xl2003 & Xl2002 - Xl97 and 2000 don't support this ... use Shell)

1st: use native VBA commands eg

Code:

Option Explicit

Sub GetDir()
Dim strDir As String

On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
    '// Select the Root Dir
    '// Or link it to your cell
    .InitialFileName = "C:\"
    .Show
    strDir = .SelectedItems(1)
End With

If Err Then Exit Sub
On Error GoTo 0

MsgBox "You selected " & strDir

End Sub

Or use the Shell Object

Code:

Sub BrowseForFolder_Shell()
'//Minimum DLL version shell32.dll version 4.71 or later
'//Minimum operating systems  Windows*2000, Windows NT 4.0 with Internet Explorer*4.0,
'//Windows*98, Windows 95 with Internet Explorer*4.0
Dim objShell As Object
Dim objFolder As Object
Dim strFolderFullPath As String

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Please select a folder", 0, "C:\")

If (Not objFolder Is Nothing) Then
    '// NB: If SpecFolder= 0 = Desktop then ....
    On Error Resume Next
    If IsError(objFolder.Items.Item.Path) Then strFolderFullPath = CStr(objFolder): GoTo GotIt
    On Error GoTo 0
    '// Is it the Root Dir?...if so change
    If Len(objFolder.Items.Item.Path) > 3 Then
        strFolderFullPath = objFolder.Items.Item.Path & Application.PathSeparator
    Else
        strFolderFullPath = objFolder.Items.Item.Path
    End If
Else
    MsgBox "User cancelled": GoTo Xit
End If

GotIt:
MsgBox "You selected:= " & strFolderFullPath, vbInformation, "ObjectFolder:= " & objFolder

Xit:
Set objFolder = Nothing
Set objShell = Nothing

End Sub


gubbs 03-04-2005 01:13 PM

Ivan,

Amazingly simple code to execute my desired task! Thank you very much!


All times are GMT -6. The time now is 10:00 AM.

Powered by vBulletin® Version 3.8.6
Copyright ©2000 - 2014, Jelsoft Enterprises Ltd.
All site content is protected by the Digital Millenium Act of 1998. Copyright©2001-2011 MAS Media Inc. and Extreme Visual Basic Forum. All rights reserved.
You may not copy or reproduce any portion of this site without written consent.