Public Type BROWSEINFO
    hwndOwner As Long
    pidlRoot As Long
    strDisplayName As String
    strTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    lImage As Long
End Type

Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _
  ByVal hwndOwner As Long, _
  ByVal lngFolder As Long, _
  ByRef idl As Long) As Long

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

Public Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" ( _
  bi As BROWSEINFO) As Long

Public Const CSIDL_DESKTOP As Long = &H0
Public Const CSIDL_INTERNET As Long = &H1
Public Const CSIDL_PROGRAMS As Long = &H2
Public Const CSIDL_CONTROLS As Long = &H3
Public Const CSIDL_PRINTERS As Long = &H4
Public Const CSIDL_PERSONAL As Long = &H5
Public Const CSIDL_FAVORITES As Long = &H6
Public Const CSIDL_STARTUP As Long = &H7
Public Const CSIDL_RECENT As Long = &H8
Public Const CSIDL_SENDTO As Long = &H9
Public Const CSIDL_BITBUCKET As Long = &HA
Public Const CSIDL_STARTMENU As Long = &HB
Public Const CSIDL_DESKTOPDIRECTORY As Long = &H10
Public Const CSIDL_DRIVES As Long = &H11
Public Const CSIDL_NETWORK As Long = &H12
Public Const CSIDL_NETHOOD As Long = &H13
Public Const CSIDL_FONTS As Long = &H14
Public Const CSIDL_TEMPLATES As Long = &H15

Public Const BIF_RETURNALL As Long = &H0
Public Const BIF_RETURNONLYFSDIRS As Long = &H1

Public Const cMaxPath =  260 
Public Const cNoError =  0 &
Public Const cErrorExtendedError =  1208 &

Public Function fnBrowseForFolder(ByVal lngCSIDL As Long, _
  ByVal lngBifFlags As Long, _
  strFolder As String, _
  Optional ByVal hWnd As Long =  0 , _
  Optional strTitle As String = "Select Directory") As Long

    Dim usrBrws As BROWSEINFO
    Dim lngReturn As Long
    Dim lngIDL As Long
    
    If SHGetSpecialFolderLocation(hWnd, lngCSIDL, lngIDL) =  0  _
      Then
        
        With usrBrws
            .hwndOwner = hWnd
            .pidlRoot = lngIDL
            .strDisplayName = String$(cMaxPath, vbNullChar)
            .strTitle = strTitle
            .ulFlags = lngBifFlags
        End With
        
        lngIDL = SHBrowseForFolder(usrBrws)
        
        If lngIDL Then
            strFolder = String$(cMaxPath, vbNullChar)
            
            If SHGetPathFromIDList(lngIDL, strFolder) Then
                strFolder = fnTrimNull(strFolder)
                lngReturn = cNoError
            Else
                strFolder = fnTrimNull(usrBrws.strDisplayName)
                lngReturn = cNoError
            End If
        Else
            lngReturn = cErrorExtendedError
        End If
    Else
        lngReturn = cErrorExtendedError
    End If
    
    fnBrowseForFolder = lngReturn
End Function

Function fnTrimNull( _
  ByVal strValue As String) As String
    Dim intPos As Integer
    
    intPos = InStr(strValue, vbNullChar)
    
    Select Case intPos
        Case  0 
        Case  1 
            fnTrimNull = ""
        Case Is >  1 
            fnTrimNull = Left$(strValue, intPos -  1 )
        End Select
End Function

Public Sub Test()
    Dim strFolder As String
    
    fnBrowseForFolder CSIDL_PERSONAL, _
      BIF_RETURNONLYFSDIRS, strFolder
    
    MsgBox strFolder
End Sub