Robin Lawrence
rgilimited at btconnect.com
Tue Jan 6 10:24:23 CST 2004
Andy,
I use this folder browser from Carl Tribble
<Code>
'.======================================================================
===
'.Browse Folders Module
'.Copyright 1999 Tribble Software. All rights reserved.
'.Phone : (616) 455-2055
'.E-mail : carltribble at earthlink.net
'.======================================================================
===
' DO NOT DELETE THE COMMENTS ABOVE. All other comments in this module
' may be deleted from production code, but lines above must remain.
'-----------------------------------------------------------------------
---
'.Description : This module calls three functions in shell32.dll to
allow
'. the user to browse for a folder.
'.
'.Written By : Carl Tribble
'.Date Created : 10/05/1999 08:06:31 PM
'.Rev. History :
' Comments : The public entry point is the procedure
tsGetPathFromUser,
' The selected folder name is returned in the form of a
full
' path but without the trailing "\". If the User presses
' Cancel, or an error occurs, the procedure returns Null.
' This module is completely self-contained. Simply copy
it
' into your database to use it.
'.----------------------------------------------------------------------
---
'.
' ADDITIONAL NOTES:
'
' If you want your user to browse for file names you must use the
module
' basBrowseFiles instead, or the common dialog activeX control.
'
' TO STREAMLINE this module for production programs, you should remove:
' 1) Unnecessary comments
' 2) Flag and Root Folder Constants which you do not intend to use.
' 3) The test procedure tsGetPathFromUserTest
' *DO NOT REMOVE ANYTHING ELSE. Everything else is required.
'
'-----------------------------------------------------------------------
---
'
' INSTRUCTIONS:
'
' ( For a working example, open the Debug window )
' ( and enter tsGetPathFromUserTest. )
' ( )
' ( frmBrowseFoldersTest, if available, provides )
' ( additional testing features. )
'
'.All the arguments for the function are optional. You may call it with
no
'.arguments whatsoever and simply assign its return value to a variable
of
'.the Variant type. For example:
'.
'. varFileName = tsGetPathFromUser()
'.
'.The function will return:
'. the full path selected by the user, or
'. Null if an error occurs or if the user presses Cancel.
'.
'.Optional arguments may include any of the following:
'. rlngFlags : one or more of the tscBF* Flag constants (declared
'. below). Combine multiple constants like this:
'. tscBFReturnOnlyFSDirs Or tscBFDontGoBelowDomain
'. lngRootFolder : a tscRF Root Folder constant (declared below)
indicating
'. what folder you want to start with. These constants
are
'. not to be combined, just pick the one you want to
use.
'. strHeaderMsg : a message you want to appear at the top of the dialog
'. box. Note although it is refered to internally as
the
'. Title it is NOT the dialog title, aka caption (the
' caption is always "Browse for Folder"). The message
' can be up to about 110 characters in length and
' up to two lines. It appears below the Title bar, but
' above the actual folder box.
'
'.----------------------------------------------------------------------
---
'.
Option Compare Database
Option Explicit
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, _
pidl As ITEMIDLIST) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Type SHITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
' Flag Constants
Public Const tscBFReturnOnlyFSDirs = &H1
Public Const tscBFDontGoBelowDomain = &H2
Public Const tscBFStatusText = &H4
Public Const tscBFReturnFSAncestors = &H8
Public Const tscBFBrowseForComputer = &H1000
Public Const tscBFBrowseForPrinter = &H2000
' Root Folder Constants
Public Const tscRFDesktop = &H0
Public Const tscRFPrograms = &H2
Public Const tscRFControls = &H3
Public Const tscRFPrinters = &H4
Public Const tscRFPersonal = &H5
Public Const tscRFFavorites = &H6
Public Const tscRFRecent = &H8
Public Const tscRFBitBucket = &HA
Public Const tscRFDesktopDirectory = &H10
Public Const tscRFDrives = &H11
Public Const tscRFNetwork = &H12
Public Const tscRFNethood = &H13
Public Const tscRFTemplates = &H15
Public Function tsGetPathFromUser( _
Optional ByRef rlngflags As Long = tscBFReturnOnlyFSDirs, _
Optional ByVal lngRootFolder As Long = tscRFDrives, _
Optional ByVal strHeaderMsg As String = "") As Variant
On Error GoTo tsGetPathFromUser_Err
Const conBufLen = 512
Dim bi As BROWSEINFO
Dim idl As ITEMIDLIST
Dim lngReturn As Long
Dim pidl As Long
Dim strpath As String
bi.hOwner = Application.hWndAccessApp
lngReturn = SHGetSpecialFolderLocation( _
ByVal Application.hWndAccessApp, lngRootFolder, idl)
bi.pidlRoot = idl.mkid.cb
bi.lpszTitle = strHeaderMsg
bi.ulFlags = rlngflags
pidl = SHBrowseForFolder(bi)
strpath = Space(conBufLen)
lngReturn = SHGetPathFromIDList(ByVal pidl, ByVal strpath)
If lngReturn <> 0 Then
tsGetPathFromUser = tsTrimNull(strpath)
Else
tsGetPathFromUser = Null
End If
tsGetPathFromUser_End:
On Error GoTo 0
Exit Function
tsGetPathFromUser_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basBrowseFolders.tsGetPathFromUser"
Resume tsGetPathFromUser_End
End Function
' Trim Nulls from a string returned by an API call.
Private Function tsTrimNull(ByVal strItem As String) As String
On Error GoTo tsTrimNull_Err
Dim i As Integer
i = InStr(strItem, vbNullChar)
If i > 0 Then
tsTrimNull = Left(strItem, i - 1)
Else
tsTrimNull = strItem
End If
tsTrimNull_End:
On Error GoTo 0
Exit Function
tsTrimNull_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basBrowseFolders.tsTrimNull"
Resume tsTrimNull_End
End Function
'-----------------------------------------------------------------------
---
' Project : tsDeveloperTools
' Description : An example of how you can call tsGetPathFromUser()
' Calls :
' Accepts :
' Returns :
' Written By : Carl Tribble
' Date Created : 05/04/1999 11:19:41 AM
' Rev. History :
' Comments : This is provided merely as an example to the programmer
' It may be safely deleted from production code.
'-----------------------------------------------------------------------
---
Public Sub tsGetPathFromUserTest()
On Error GoTo tsGetPathFromUserTest_Err
Dim lngFlags As Long
Dim lngRoot As Long
Dim strHeaderMsg As String
Dim varPath As Variant
lngFlags = tscBFReturnOnlyFSDirs Or tscBFDontGoBelowDomain
lngRoot = tscRFDrives
strHeaderMsg = "This is where the header message displays. " _
& vbCrLf & "Note it only holds 2 full lines (about 100 " _
& "characters altogether)."
varPath = tsGetPathFromUser(lngFlags, lngRoot, strHeaderMsg)
If IsNull(varPath) Then
Debug.Print "User pressed 'Cancel'."
Else
Debug.Print varPath
End If
tsGetPathFromUserTest_End:
On Error GoTo 0
Exit Sub
tsGetPathFromUserTest_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in sub basBrowseFolders.tsGetPathFromUserTest"
Resume tsGetPathFromUserTest_End
End Sub
<Code>
-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Andy Lacey
Sent: 06 January 2004 15:42
To: Access Developers discussion and problem solving
Subject: [AccessD] Get Folder Name via API
Must've done thsi before but can't find it. I want to ask the user for a
folder name (into which I'm going to store stuff). I want to use the
Windows
common file dialog so that it looks neat and offers to create a new
folder
and so on. However I don't want to put a Common Dialog control on the
form
(always has version issues) so want to use the API method. But the code
I
have (from Dev Ashish) insists on a filename not just a folder, and the
other code on his site to browse a folder list doesn't use the normal
dialog. Anyone got code for this?
--
Andy Lacey
http://www.minstersystems.co.uk
________________________________________________
Message sent using UebiMiau 2.7.2
_______________________________________________
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com