Snippet Library

'[ MODULE1.BAS ]

Option Explicit
Private Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BFFM_INITIALIZED = 1
Private Const MAX_PATH = 260

Private Declare Sub CoTaskMemFree Lib "ole32.dll" ( _
        ByVal hMem As Long)

Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
        ByVal lpString1 As String, _
        ByVal lpString2 As String) _
        As Long

Private Declare Function MoveWindow Lib "user32" ( _
        ByVal hwnd As Long, _
        ByVal x As Long, _
        ByVal y As Long, _
        ByVal nWidth As Long, _
        ByVal nHeight As Long, _
        ByVal bRepaint As Long) _
        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

Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String) As String

    Dim iNull As Integer
    Dim lpIDList As Long
    Dim lResult As Long
    Dim sPath As String
    Dim udtBI As BrowseInfo

    With udtBI
        .hWndOwner = hWndOwner
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
        .lpfnCallback = passbackAddress(AddressOf BrowseCallbackProc)
    End With

    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        lResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)
        If iNull Then
            sPath = Left$(sPath, iNull - 1)
        End If
    End If

    BrowseForFolder = sPath

End Function

Public Function BrowseCallbackProc(ByVal BrowseHWnd As Long, ByVal uMsg As
    Long, ByVal wParam As Long, ByVal lpData As Long) As Long

    Dim lretv As Long

    If uMsg = BFFM_INITIALIZED Then
        lretv = MoveWindow(BrowseHWnd, 50, 50, 425, 400, 1)
    End If

    BrowseCallbackProc = 0

End Function

Public Function passbackAddress(ByVal lpfn As Long) As Long
    passbackAddress = lpfn
End Function

'[ FORM1.FRM ]

Private Sub Command1_Click()
    Dim sMyString As String
    sMyString = BrowseForFolder(Form1.hwnd, "Pick a folder to copy the file
    To:")
    MsgBox sMyString
End Sub

;