1Attribute VB_Name = "BrowseDirectorysOnly"
2'/*************************************************************************
3' *
4' * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
5' *
6' * Copyright 2000, 2010 Oracle and/or its affiliates.
7' *
8' * OpenOffice.org - a multi-platform office productivity suite
9' *
10' * This file is part of OpenOffice.org.
11' *
12' * OpenOffice.org is free software: you can redistribute it and/or modify
13' * it under the terms of the GNU Lesser General Public License version 3
14' * only, as published by the Free Software Foundation.
15' *
16' * OpenOffice.org is distributed in the hope that it will be useful,
17' * but WITHOUT ANY WARRANTY; without even the implied warranty of
18' * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19' * GNU Lesser General Public License version 3 for more details
20' * (a copy is included in the LICENSE file that accompanied this code).
21' *
22' * You should have received a copy of the GNU Lesser General Public License
23' * version 3 along with OpenOffice.org.  If not, see
24' * <http://www.openoffice.org/license.html>
25' * for a copy of the LGPLv3 License.
26' *
27' ************************************************************************/
28
29' Modified as BIF_STATUSTEXT overflows for nested folders so is no longer
30' shown.
31
32'=====================================================================================
33' Browse for a Folder using SHBrowseForFolder API function with a callback
34' function BrowseCallbackProc.
35'
36' This Extends the functionality that was given in the
37' MSDN Knowledge Base article Q179497 "HOWTO: Select a Directory
38' Without the Common Dialog Control".
39'
40' After reading the MSDN knowledge base article Q179378 "HOWTO: Browse for
41' Folders from the Current Directory", I was able to figure out how to add
42' a callback function that sets the starting directory and displays the
43' currently selected path in the "Browse For Folder" dialog.
44'
45'
46' Stephen Fonnesbeck
47' steev@xmission.com
48' http://www.xmission.com/~steev
49' Feb 20, 2000
50'
51'=====================================================================================
52' Usage:
53'
54'    Dim folder As String
55'    folder = BrowseForFolder(Me, "Select A Directory", "C:\startdir\anywhere")
56'    If Len(folder) = 0 Then Exit Sub  'User Selected Cancel
57'
58'=====================================================================================
59
60Option Explicit
61
62Private Const BIF_STATUSTEXT = &H4&
63Private Const BIF_RETURNONLYFSDIRS = 1
64Private Const BIF_DONTGOBELOWDOMAIN = 2
65Private Const MAX_PATH = 260
66
67Private Const WM_USER = &H400
68Private Const BFFM_INITIALIZED = 1
69Private Const BFFM_SELCHANGED = 2
70Private Const BFFM_SETSELECTION = (WM_USER + 102)
71
72Private 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
73Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
74Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
75Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
76
77Private Type BrowseInfo
78  hWndOwner      As Long
79  pIDLRoot       As Long
80  pszDisplayName As Long
81  lpszTitle      As Long
82  ulFlags        As Long
83  lpfnCallback   As Long
84  lParam         As Long
85  iImage         As Long
86End Type
87
88Private m_CurrentDirectory As String   'The current directory
89'
90
91Public Function BrowseForFolder(owner As Form, Title As String, StartDir As String) As String
92  'Opens a Treeview control that displays the directories in a computer
93
94  Dim lpIDList As Long
95  Dim szTitle As String
96  Dim sBuffer As String
97  Dim tBrowseInfo As BrowseInfo
98  m_CurrentDirectory = StartDir & vbNullChar
99
100  szTitle = Title
101  With tBrowseInfo
102    .hWndOwner = owner.hWnd
103    .lpszTitle = lstrcat(szTitle, "")
104    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN '+ BIF_STATUSTEXT
105    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
106  End With
107
108  lpIDList = SHBrowseForFolder(tBrowseInfo)
109  If (lpIDList) Then
110    sBuffer = Space(MAX_PATH)
111    SHGetPathFromIDList lpIDList, sBuffer
112    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
113    BrowseForFolder = sBuffer
114  Else
115    BrowseForFolder = ""
116  End If
117
118End Function
119
120Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
121
122  Dim lpIDList As Long
123  Dim ret As Long
124  Dim sBuffer As String
125
126  On Error Resume Next  'Sugested by MS to prevent an error from
127                        'propagating back into the calling process.
128
129  Select Case uMsg
130
131    Case BFFM_INITIALIZED
132      Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
133
134  End Select
135
136  BrowseCallbackProc = 0
137
138End Function
139
140' This function allows you to assign a function pointer to a vaiable.
141Private Function GetAddressofFunction(add As Long) As Long
142  GetAddressofFunction = add
143End Function
144