'[ 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 '[ 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 |