Option ExplicitPrivate Const MAX_PATH = 260Private Const BIF_RETURNONLYFSDIRS = 1'With New Folder'Private Const BIF_NEWDIALOGSTYLE As Long = & H40'udtBI.ulFlags = BIF_RETURNONLYFSDIRS BIF_NEWDIALOGSTYLE'Browse the Share'Private Const BIF_DONTGOBELOWDOMAIN = 2'udtBI.ulFlags = BIF_RETURNONLYFSDIRS BIF_DONTGOBELOWDOMAIN BIF_NEWDIALOGSTYLE
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 Longend Type
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As LongPrivate Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As LongPrivate Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, Byval Lpbuffer As String) As longprivate declare sub cotaskmemfree lib "ole32.dll" (Byval HMEM As Long)
Private Function BrowseFolder (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 udtBI.hwndOwner = hwndOwner udtBI.lpszTitle = lstrcat (sPrompt, "") udtBI.ulFlags = BIF_RETURNONLYFSDIRS 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 browsefolder = Spathend Function
