Attribute VB_Name = "BrowseFolder"
' Add to a BAS MODULE
Option Explicit
'
' Usage:
'Text1 = BrowseForFolder(Me.hwnd, "Select A Folder Dude!", "D:\")
'
Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA = (WM_USER + 102)
               
' The browse dialog box has finished initializing. lParam is NULL.
Private Const BFFM_INITIALIZED = 1

' The selection has changed. lParam is a pointer to the item identifier
' list for the newly selected folder.
Private Const BFFM_SELECTIONCHANGED = 2

'For finding a folder to start document searching
Private Const BIF_RETURNONLYFSDIRS As Long = &H1

'For starting the Find Computer
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2

'Top of the dialog has 2 lines of text for
'BROWSEINFO.lpszTitle and one line if this flag is set.
'Passing the message BFFM_SETSTATUSTEXTA to the hwnd
'can set the rest of the text.  This is not used with
'BIF_USENEWUI and BROWSEINFO.lpszTitle gets all three
'lines of text.
Private Const BIF_STATUSTEXT As Long = &H4

Private Const BIF_RETURNFSANCESTORS As Long = &H8

'Add an edit box to the dialog: SHELL 4.71 or later only!
Private Const BIF_EDITBOX As Long = &H10

'insist on valid result (or CANCEL)
Private Const BIF_VALIDATE As Long = &H20

'Use the new dialog layout with the ability
'to resize: SHELL 5.0 or later only!
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_USENEWUI As Long = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)

'Allow URLs to be displayed or entered
'(Requires BIF_USENEWUI): SHELL 5.0 or later only!
Private Const BIF_BROWSEINCLUDEURLS As Long = &H80

'Add a UA hint to the dialog, in place of the
'edit box. May not be combined with BIF_EDITBOX: SHELL 6.0 or later only!
Private Const BIF_UAHINT As Long = &H100

'Do not add the "New Folder" button to the dialog.
'Only applicable with BIF_NEWDIALOGSTYLE: SHELL 6.0 or later only!
Private Const BIF_NONEWFOLDERBUTTON As Long = &H200

'Browsing for Computers
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000

'Browsing for Printers
Private Const BIF_BROWSEFORPRINTER As Long = &H2000

'Browsing for Everything
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000

'sharable resources on remote systems displayed
'(remote shares, requires BIF_USENEWUI): SHELL 5.0 or later only!
Private Const BIF_SHAREABLE As Long = &H8000&
Private Const MAX_PATH = 260

  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

  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

  Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" _
    (ByVal pIdl As Long, ByVal szPath As String) As Long

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

  Private Declare Function SHBrowseForFolder Lib "shell32" (lpBI As BrowseInfo) As Long

  Private Declare Function LocalAlloc Lib "kernel32" _
     (ByVal uFlags As Long, _
      ByVal uBytes As Long) As Long

  Private Declare Function LocalFree Lib "kernel32" _
     (ByVal hMem As Long) As Long

  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

  Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
  End Type

  Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

  Private Declare Function SetWindowPos& Lib "user32" (ByVal hwnd&, ByVal hWndInsertAfter&, ByVal X&, ByVal Y&, ByVal cx&, ByVal cy&, ByVal wFlags&)

  Private rct As RECT

'Callback procedure
Private 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
        'Set Initial Folder
        Call SendMessage(hwnd, BFFM_SETSELECTIONA, True, ByVal lpData)
        Call CenterDialogueForm(hwnd)
   End Select

End Function

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

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

  With udtBI
    .hWndOwner = hWndOwner
    .lpszTitle = sPrompt
    .pIDLRoot = 0&
    .ulFlags = BIF_VALIDATE + BIF_USENEWUI + BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN ' + BIF_EDITBOX
    lLenStartfolder& = Len(StartFolder$)
    If lLenStartfolder& Then
      lLenStartfolder& = lLenStartfolder& + 1
      .lpfnCallback = FARPROC(AddressOf BrowseCallbackProcStr)
      lpSelPath = LocalAlloc(LPTR, lLenStartfolder&)
      CopyMemory ByVal lpSelPath, ByVal StartFolder, lLenStartfolder&
      .lParam = lpSelPath
    End If
  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
  If lpSelPath Then
    Call LocalFree(lpSelPath)
  End If

  BrowseForFolder = sPath

End Function

Sub CenterDialogueForm(hwnd&)
  'Center browser form
  Dim Sw&, SH&, XX&, YY&

  Call GetWindowRect(hwnd&, rct)
  With Screen
    Sw = .Width \ .TwipsPerPixelX
    SH = .Height \ .TwipsPerPixelY
  End With
  With rct
    XX = (Sw - (.Right - .Left)) \ 2
    YY = (SH - (.Bottom - .Top)) \ 2
  End With
  Call SetWindowPos(hwnd&, 0&, XX, YY, 0&, 0&, 1)
End Sub

Private Function FARPROC(pfn As Long) As Long

  'A dummy procedure that receives and returns
  'the value of the AddressOf operator.

  '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