Option Explicit

 

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 Declare Function SendMessageA Lib "user32.dll" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long

 

Const WM_CREATE As Long = 1

 

Private Type BROWSEINFO

    hwndOwner      As Long

    pIDLRoot       As Long

    pszDisplayName As String

    lpszTitle      As String

    ulFlags        As Long

    lpfnCallback   As Long

    lParam         As Long

    iImage         As Long

End Type

 

Public Function GetFolder(ByVal hWnd As Long, ByVal sTitle As String, ByVal sCaption As String) As String

    Dim lpIDList As Long

    Dim sBuffer As String

    Dim szTitle As String

    Dim tBrowseInfo As BROWSEINFO

            

    With tBrowseInfo

        .hwndOwner = hWnd ' Parent window

        .lpszTitle = sTitle ' Title of folders list

        .pszDisplayName = App.Title

        .lpfnCallback = Val(AddressOf BrowseFolderCallback) ' Pointer to callback procedure

        sCaption = StrConv(sCaption, vbFromUnicode) ' Convert string

        .lParam = StrPtr(sCaption) ' Pass the caption through lParam

    End With

    lpIDList = SHBrowseForFolder(tBrowseInfo)

        

    If (lpIDList) Then

        sBuffer = String(260, 0)

        SHGetPathFromIDList lpIDList, sBuffer

        If InStr(sBuffer, vbNullChar) <> 0 Then sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)

        GetFolder = sBuffer

    End If

End Function

 

Private Function BrowseFolderCallback(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Select Case uMsg

        Case WM_CREATE

            SendMessageA hWnd, 12, 0, lParam ' Sets our caption (pointer in lParam) to dialogbox

    End Select

    BrowseFolderCallback = 0

End Function