1cdf0e10cSrcweirAttribute VB_Name = "BrowseDirectorysOnly" 2*8e9e5c11SAndrew Rist'************************************************************************* 3*8e9e5c11SAndrew Rist' 4*8e9e5c11SAndrew Rist' Licensed to the Apache Software Foundation (ASF) under one 5*8e9e5c11SAndrew Rist' or more contributor license agreements. See the NOTICE file 6*8e9e5c11SAndrew Rist' distributed with this work for additional information 7*8e9e5c11SAndrew Rist' regarding copyright ownership. The ASF licenses this file 8*8e9e5c11SAndrew Rist' to you under the Apache License, Version 2.0 (the 9*8e9e5c11SAndrew Rist' "License"); you may not use this file except in compliance 10*8e9e5c11SAndrew Rist' with the License. You may obtain a copy of the License at 11*8e9e5c11SAndrew Rist' 12*8e9e5c11SAndrew Rist' http://www.apache.org/licenses/LICENSE-2.0 13*8e9e5c11SAndrew Rist' 14*8e9e5c11SAndrew Rist' Unless required by applicable law or agreed to in writing, 15*8e9e5c11SAndrew Rist' software distributed under the License is distributed on an 16*8e9e5c11SAndrew Rist' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 17*8e9e5c11SAndrew Rist' KIND, either express or implied. See the License for the 18*8e9e5c11SAndrew Rist' specific language governing permissions and limitations 19*8e9e5c11SAndrew Rist' under the License. 20*8e9e5c11SAndrew Rist' 21*8e9e5c11SAndrew Rist'************************************************************************* 22cdf0e10cSrcweir 23cdf0e10cSrcweir' Modified as BIF_STATUSTEXT overflows for nested folders so is no longer 24cdf0e10cSrcweir' shown. 25cdf0e10cSrcweir 26cdf0e10cSrcweir'===================================================================================== 27cdf0e10cSrcweir' Browse for a Folder using SHBrowseForFolder API function with a callback 28cdf0e10cSrcweir' function BrowseCallbackProc. 29cdf0e10cSrcweir' 30cdf0e10cSrcweir' This Extends the functionality that was given in the 31cdf0e10cSrcweir' MSDN Knowledge Base article Q179497 "HOWTO: Select a Directory 32cdf0e10cSrcweir' Without the Common Dialog Control". 33cdf0e10cSrcweir' 34cdf0e10cSrcweir' After reading the MSDN knowledge base article Q179378 "HOWTO: Browse for 35cdf0e10cSrcweir' Folders from the Current Directory", I was able to figure out how to add 36cdf0e10cSrcweir' a callback function that sets the starting directory and displays the 37cdf0e10cSrcweir' currently selected path in the "Browse For Folder" dialog. 38cdf0e10cSrcweir' 39cdf0e10cSrcweir' 40cdf0e10cSrcweir' Stephen Fonnesbeck 41cdf0e10cSrcweir' steev@xmission.com 42cdf0e10cSrcweir' http://www.xmission.com/~steev 43cdf0e10cSrcweir' Feb 20, 2000 44cdf0e10cSrcweir' 45cdf0e10cSrcweir'===================================================================================== 46cdf0e10cSrcweir' Usage: 47cdf0e10cSrcweir' 48cdf0e10cSrcweir' Dim folder As String 49cdf0e10cSrcweir' folder = BrowseForFolder(Me, "Select A Directory", "C:\startdir\anywhere") 50cdf0e10cSrcweir' If Len(folder) = 0 Then Exit Sub 'User Selected Cancel 51cdf0e10cSrcweir' 52cdf0e10cSrcweir'===================================================================================== 53cdf0e10cSrcweir 54cdf0e10cSrcweirOption Explicit 55cdf0e10cSrcweir 56cdf0e10cSrcweirPrivate Const BIF_STATUSTEXT = &H4& 57cdf0e10cSrcweirPrivate Const BIF_RETURNONLYFSDIRS = 1 58cdf0e10cSrcweirPrivate Const BIF_DONTGOBELOWDOMAIN = 2 59cdf0e10cSrcweirPrivate Const MAX_PATH = 260 60cdf0e10cSrcweir 61cdf0e10cSrcweirPrivate Const WM_USER = &H400 62cdf0e10cSrcweirPrivate Const BFFM_INITIALIZED = 1 63cdf0e10cSrcweirPrivate Const BFFM_SELCHANGED = 2 64cdf0e10cSrcweirPrivate Const BFFM_SETSELECTION = (WM_USER + 102) 65cdf0e10cSrcweir 66cdf0e10cSrcweirPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long 67cdf0e10cSrcweirPrivate Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long 68cdf0e10cSrcweirPrivate Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long 69cdf0e10cSrcweirPrivate Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long 70cdf0e10cSrcweir 71cdf0e10cSrcweirPrivate Type BrowseInfo 72cdf0e10cSrcweir hWndOwner As Long 73cdf0e10cSrcweir pIDLRoot As Long 74cdf0e10cSrcweir pszDisplayName As Long 75cdf0e10cSrcweir lpszTitle As Long 76cdf0e10cSrcweir ulFlags As Long 77cdf0e10cSrcweir lpfnCallback As Long 78cdf0e10cSrcweir lParam As Long 79cdf0e10cSrcweir iImage As Long 80cdf0e10cSrcweirEnd Type 81cdf0e10cSrcweir 82cdf0e10cSrcweirPrivate m_CurrentDirectory As String 'The current directory 83cdf0e10cSrcweir' 84cdf0e10cSrcweir 85cdf0e10cSrcweirPublic Function BrowseForFolder(owner As Form, Title As String, StartDir As String) As String 86cdf0e10cSrcweir 'Opens a Treeview control that displays the directories in a computer 87cdf0e10cSrcweir 88cdf0e10cSrcweir Dim lpIDList As Long 89cdf0e10cSrcweir Dim szTitle As String 90cdf0e10cSrcweir Dim sBuffer As String 91cdf0e10cSrcweir Dim tBrowseInfo As BrowseInfo 92cdf0e10cSrcweir m_CurrentDirectory = StartDir & vbNullChar 93cdf0e10cSrcweir 94cdf0e10cSrcweir szTitle = Title 95cdf0e10cSrcweir With tBrowseInfo 96cdf0e10cSrcweir .hWndOwner = owner.hWnd 97cdf0e10cSrcweir .lpszTitle = lstrcat(szTitle, "") 98cdf0e10cSrcweir .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN '+ BIF_STATUSTEXT 99cdf0e10cSrcweir .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function. 100cdf0e10cSrcweir End With 101cdf0e10cSrcweir 102cdf0e10cSrcweir lpIDList = SHBrowseForFolder(tBrowseInfo) 103cdf0e10cSrcweir If (lpIDList) Then 104cdf0e10cSrcweir sBuffer = Space(MAX_PATH) 105cdf0e10cSrcweir SHGetPathFromIDList lpIDList, sBuffer 106cdf0e10cSrcweir sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1) 107cdf0e10cSrcweir BrowseForFolder = sBuffer 108cdf0e10cSrcweir Else 109cdf0e10cSrcweir BrowseForFolder = "" 110cdf0e10cSrcweir End If 111cdf0e10cSrcweir 112cdf0e10cSrcweirEnd Function 113cdf0e10cSrcweir 114cdf0e10cSrcweirPrivate Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long 115cdf0e10cSrcweir 116cdf0e10cSrcweir Dim lpIDList As Long 117cdf0e10cSrcweir Dim ret As Long 118cdf0e10cSrcweir Dim sBuffer As String 119cdf0e10cSrcweir 120cdf0e10cSrcweir On Error Resume Next 'Sugested by MS to prevent an error from 121cdf0e10cSrcweir 'propagating back into the calling process. 122cdf0e10cSrcweir 123cdf0e10cSrcweir Select Case uMsg 124cdf0e10cSrcweir 125cdf0e10cSrcweir Case BFFM_INITIALIZED 126cdf0e10cSrcweir Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory) 127cdf0e10cSrcweir 128cdf0e10cSrcweir End Select 129cdf0e10cSrcweir 130cdf0e10cSrcweir BrowseCallbackProc = 0 131cdf0e10cSrcweir 132cdf0e10cSrcweirEnd Function 133cdf0e10cSrcweir 134cdf0e10cSrcweir' This function allows you to assign a function pointer to a vaiable. 135cdf0e10cSrcweirPrivate Function GetAddressofFunction(add As Long) As Long 136cdf0e10cSrcweir GetAddressofFunction = add 137cdf0e10cSrcweirEnd Function 138