SHBrowseForFolder Dialog

Is it possible to show the dialog with one folder already selected (e.g. c:\win)?

I have a button on my form to display the dialog. When the user clicks on the button a second time I would like the dialog to start with the previously selected path.

Thanx,
Nina

Code:

---

'in a form
Option Explicit

Private Sub Command1_Click()
    Dim spath$
    spath = BrowseForFolderByPIDL(Me, "Select archive folder:", "c:\Sp")
End Sub


'in a module
Option Explicit

Public 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 Declare Function SHBrowseForFolder Lib _
        "shell32.dll" Alias "SHBrowseForFolderA" _
        (lpBrowseInfo As BROWSEINFO) As Long

Public Declare Function SHGetPathFromIDList Lib _
        "shell32.dll" Alias "SHGetPathFromIDListA" _
        (ByVal pidl As Long, _
        ByVal pszPath As String) As Long

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

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 Declare Sub MoveMemory Lib "kernel32" _
        Alias "RtlMoveMemory" _
        (pDest As Any, _
        pSource As Any, _
        ByVal dwLength As Long)

Public Const MAX_PATH = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1

'eg. To Use: BrowseForFolderByPIDL(Me, "Select archive folder:","c:\windows")

'Constants ending in 'A' are for Win95 ANSI
'calls; those ending in 'W' are the wide Unicode
'calls for NT.

'Sets the status text to the null-terminated
'string specified by the lParam parameter.
'wParam is ignored and should be set to 0.
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)

'If the lParam  parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)

'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SELECTIONCHANGED
'message.
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)

'specific to the PIDL method
'Undocumented call for the example. IShellFolder's
'ParseDisplayName member function should be used instead.
Public Declare Function SHSimpleIDListFromPath Lib _
        "shell32" Alias "#162" _
        (ByVal szPath As String) As Long

'specific to the STRING method
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 Function lstrcpyA Lib "kernel32" _
        (lpString1 As Any, lpString2 As Any) As Long

Public Declare Function lstrlenA Lib "kernel32" _
        (lpString As Any) As Long

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

'windows-defined type OSVERSIONINFO
Public Type OSVERSIONINFO
    OSVSize        As Long
    dwVerMajor      As Long
    dwVerMinor      As Long
    dwBuildNumber  As Long
    PlatformID      As Long
    szCSDVersion    As String * 128
End Type

Public Const VER_PLATFORM_WIN32_NT = 2

Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

Public Function BrowseCallbackProcStr(ByVal hWnd As Long, _
            ByVal uMsg As Long, _
            ByVal lParam As Long, _
            ByVal lpData As Long) As Long

    '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 Else:

    End Select

End Function

Public Function BrowseCallbackProc(ByVal hWnd As Long, _
            ByVal uMsg As Long, _
            ByVal lParam As Long, _
            ByVal lpData As Long) As Long

    '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 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.

    'Obtain and set the address of the callback
    '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

Public Function BrowseForFolderByPIDL(pFrm As Form, pstrPrompt As String, ByVal sSelPath As String) As String

    Dim BI As BROWSEINFO
    Dim pidl As Long
    Dim spath As String * MAX_PATH

    sSelPath = UnFixPath(sSelPath)

    With BI
        .hOwner = pFrm.hWnd
        .pidlRoot = 0
        .lpszTitle = pstrPrompt
        .lpfn = FARPROC(AddressOf BrowseCallbackProc)
        .lParam = GetPIDLFromPath(sSelPath) 'replaces '=
SHSimpleIDListFromPath (sSelPath) '
    End With

    pidl = SHBrowseForFolder(BI)

    If pidl Then
        If SHGetPathFromIDList(pidl, spath) Then
            BrowseForFolderByPIDL = 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 IsWinNT() As Boolean

    Dim OSV As OSVERSIONINFO

    OSV.OSVSize = Len(OSV)

    'API returns 1 if a successful call
    If GetVersionEx(OSV) = 1 Then

        'PlatformId contains a value representing
        'the OS, so if its VER_PLATFORM_WIN32_NT,
        'return true
        IsWinNT = OSV.PlatformID = VER_PLATFORM_WIN32_NT
    End If

End Function

' Removes trailing backslash from a diretory path if found
Function UnFixPath(ByVal pstrPath As String) As String
    If Len(pstrPath) > 0 Then
        If Right$(pstrPath, 1) = "\" Then
            UnFixPath = Left$(pstrPath, Len(pstrPath) - 1)
            Exit Function
        End If
    End If
    UnFixPath = pstrPath
End Function

---

crispin,

Did you write that code?

why - you wanna gimme a job? ;)

If you wrote that from scratch, sure thing.

I didn't catch if that was that a yes or no?

Who should I give credit to in my apps?

Not all mine...I took it from the web, and messed it about a bit, I cant think who wrote it to begin with, but don't worry about crediting me - I prefer the man of mystery approach...

Well that is some nice code :cool:

I got some more coming up on how to nick the message text from the messenger windows, it's childs play compared to the above, but if you're interested...

http://forums.vb-world.net/showthrea...threadid=83852

Thanks a lot, that was exactely what I needed!!