Option Explicit

Private Const MAX_PATH =  260 
Private Const BIF_RETURNONLYFSDIRS = &H1&
Private Const BIF_STATUSTEXT = &H4
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED =  1 
Private Const BFFM_SELCHANGED =  2 
Private Const BFFM_SETSTATUSTEXT = WM_USER +  100 
Private Const BFFM_SETSELECTION = WM_USER +  102 
Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_PIDL = &H8
Private Const WM_SETTEXT = &HC

Private Declare Function BrowseForFolder Lib "shell32" Alias "SHBrowseForFolder" _
    (lpbi As udtBrowseInfo) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDList" _
    (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" _
    (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As udtShowFileInfo, ByVal cbFileInfo As Long, ByVal uFlags As Long) 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
    
Type udtBrowseInfo 'brs
    hwndOwner       As Long
    pidlRoot        As Long
    pszDisplayName  As String
    lpszTitle       As String
    ulFlags         As Long
    lpfn            As Long
    lParam          As String
    iImage          As Long
End Type

Type udtShowFileInfo 'sfi
    hIcon           As Long
    iIcon           As Long
    dwAttributes    As Long
    szDisplayName   As String * MAX_PATH
    szTypeName      As String *  80 
End Type

Private Sub BrowseCallbackProc(ByVal plngHndWnd As Long, _
                               ByVal plngUMsg As Long, _
                               ByVal plngParam As Long, _
                               ByVal pstrLpData As String)
    
    Dim strPath As String * MAX_PATH
    Dim sfiMyPath As udtShowFileInfo
            
    If plngUMsg = BFFM_SELCHANGED Then
        
        GetPathFromIDList plngParam, strPath
        
        If Asc(strPath) =  0  Then
            SHGetFileInfo plngParam,  0 , sfiMyPath, Len(sfiMyPath), SHGFI_DISPLAYNAME Or SHGFI_PIDL
            strPath = sfiMyPath.szDisplayName
        End If
        
        SendMessage plngHndWnd, BFFM_SETSTATUSTEXT,  0 &, ByVal strPath
        
    ElseIf plngUMsg = BFFM_INITIALIZED Then
        
        SendMessage plngHndWnd, BFFM_SETSELECTION, True, ByVal pstrLpData
        SendMessage plngHndWnd, WM_SETTEXT,  0 , ByVal "Browse for Folder"
        
    End If
    
End Sub

Public Function BrowseFolder(ByVal pstrStartFolder As String) As String
 
    Dim brsMyBrwsInfo As udtBrowseInfo
    Dim lngRetFldrBrws As Long
    Dim strPath As String * MAX_PATH
    Dim strReturn As String
    
    CopyMemory brsMyBrwsInfo.lpfn, AddressOf BrowseCallbackProc,  4 
    
    With brsMyBrwsInfo
        .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT
        .hwndOwner = Screen.ActiveForm.hwnd
        .lParam = StrConv(Trim$(pstrStartFolder), vbUnicode)
        .lpszTitle = "Please select your directory:"
    End With
    
    lngRetFldrBrws = BrowseForFolder(brsMyBrwsInfo)
    
    If lngRetFldrBrws Then
        GetPathFromIDList lngRetFldrBrws, strPath
        strReturn = Left$(strPath, InStr(strPath, vbNullChar) -  1 )
    Else
        strReturn = pstrStartFolder
    End If
    
    BrowseFolder = IIf(strReturn = vbNullString, vbNullString, _
                   IIf(Right$(strReturn,  1 ) = "\", strReturn, strReturn & "\"))

End Function

Option Explicit

Private Sub Command1_Click()
    BrowseFolder "C:\Temp"
End Sub