Alan- In your VBA editor go to tools -> references and see if you have Microsoft Common Dialog Control 6.0 (sp3) or some other version. If you do check the box next to it and it will be included in your application. The previous code should then work. If not..... Then it would be time to pull out the big gun. Paste this into a new module, It's a module I use frequently and it's pretty self explanatory. With Access you never know what kind of install is on the users machine, this will by pass Access and use the Windows API. Watch out for word wrap by your email program. -Anthony ************************************************************************** ************************************************************************** Option Compare Database Option Explicit '--------------------------------------------------------------------------- ------- ' **MS ACCESS 2000 SR1** ' Paste this into a new module ' ' ' ' From the immediate window -> sListAllDrives -> will list all drives and path/UNC ' From the immediate window -> TestIt -> will show use of the API call to the Windows Common Dialog ' ' From a Form Module ' ------------------ ' DIM strPath as String ' ' strPath = GetUniversal(cdlGetFile) RETURNS -> \\Server\path\to file UNC Format ' strPath = cdlGetFile RETURNS -> C:\Path\to file path format ' ' ' ' ' '--------------------------------------------------------------------------- ------- Private Declare Function WNetGetUniversalName Lib "mpr" Alias "WNetGetUniversalNameA" (ByVal lpLocalPath As String, ByVal dwInfoLevel As Long, lpBuffer As Any, lpBufferSize As Long) As Long Private Const UNIVERSAL_NAME_INFO_LEVEL = 1 Private Const REMOTE_NAME_INFO_LEVEL = 2 Private Const UNIVERSAL_NAME_BUFFER_SIZE = 255 Private Const NO_ERROR = 0 Private Type UNIVERSAL_NAME_INFO lpUniversalName As Long buf(UNIVERSAL_NAME_BUFFER_SIZE - 4) As Byte End Type '------------------------------------------------------------------------- '************ Code Start ************** 'This code was originally written by Terry Kreft 'and Dev Ashish. 'It is not to be altered or distributed, 'except as part of an application. 'You are free to use it in any application, 'provided the copyright notice is left unchanged. ' ' Original Code by Terry Kreft ' Modified by Dev Ashish ' Modified By Anthony Colli 'Drive Types Private Const DRIVE_UNKNOWN = 0 Private Const DRIVE_ABSENT = 1 Private Const DRIVE_REMOVABLE = 2 Private Const DRIVE_FIXED = 3 Private Const DRIVE_REMOTE = 4 Private Const DRIVE_CDROM = 5 Private Const DRIVE_RAMDISK = 6 ' returns errors for UNC Path Private Const ERROR_BAD_DEVICE = 1200& Private Const ERROR_CONNECTION_UNAVAIL = 1201& Private Const ERROR_EXTENDED_ERROR = 1208& Private Const ERROR_MORE_DATA = 234 Private Const ERROR_NOT_SUPPORTED = 50& Private Const ERROR_NO_NET_OR_BAD_PATH = 1203& Private Const ERROR_NO_NETWORK = 1222& Private Const ERROR_NOT_CONNECTED = 2250& 'Private Const NO_ERROR = 0 Private Declare Function WNetGetConnection Lib "mpr.dll" Alias _ "WNetGetConnectionA" (ByVal lpszLocalName As String, _ ByVal lpszRemoteName As String, cbRemoteName As Long) As Long Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias _ "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, _ ByVal lpBuffer As String) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _ (ByVal nDrive As String) As Long '--------------------------------------------------------------------------- ---- '***************** Code Start ************** 'This code was originally written by Ken Getz. 'It is not to be altered or distributed, 'except as part of an application. 'You are free to use it in any application, 'provided the copyright notice is left unchanged. ' ' Code courtesy of: ' Microsoft Access 95 How-To ' Ken Getz and Paul Litwin ' Waite Group Press, 1996 Type tagOPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long strFilter As String strCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long strFile As String nMaxFile As Long strFileTitle As String nMaxFileTitle As Long strInitialDir As String strTitle As String Flags As Long nFileOffset As Integer nFileExtension As Integer strDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _ Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long Global Const ahtOFN_READONLY = &H1 Global Const ahtOFN_OVERWRITEPROMPT = &H2 Global Const ahtOFN_HIDEREADONLY = &H4 Global Const ahtOFN_NOCHANGEDIR = &H8 Global Const ahtOFN_SHOWHELP = &H10 ' You won't use these. 'Global Const ahtOFN_ENABLEHOOK = &H20 'Global Const ahtOFN_ENABLETEMPLATE = &H40 'Global Const ahtOFN_ENABLETEMPLATEHANDLE = &H80 Global Const ahtOFN_NOVALIDATE = &H100 Global Const ahtOFN_ALLOWMULTISELECT = &H200 Global Const ahtOFN_EXTENSIONDIFFERENT = &H400 Global Const ahtOFN_PATHMUSTEXIST = &H800 Global Const ahtOFN_FILEMUSTEXIST = &H1000 Global Const ahtOFN_CREATEPROMPT = &H2000 Global Const ahtOFN_SHAREAWARE = &H4000 Global Const ahtOFN_NOREADONLYRETURN = &H8000 Global Const ahtOFN_NOTESTFILECREATE = &H10000 Global Const ahtOFN_NONETWORKBUTTON = &H20000 Global Const ahtOFN_NOLONGNAMES = &H40000 ' New for Windows 95 Global Const ahtOFN_EXPLORER = &H80000 Global Const ahtOFN_NODEREFERENCELINKS = &H100000 Global Const ahtOFN_LONGNAMES = &H200000 Public Function TestIt() Dim strFilter As String Dim lngFlags As Long strFilter = ahtAddFilterItem(strFilter, "Access Files (*.mda, *.mdb)", _ "*.MDA;*.MDB") strFilter = ahtAddFilterItem(strFilter, "dBASE Files (*.dbf)", "*.DBF") strFilter = ahtAddFilterItem(strFilter, "Text Files (*.txt)", "*.TXT") strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*") MsgBox "You selected: " & ahtCommonFileOpenSave(InitialDir:="C:\", _ Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, _ DialogTitle:="Hello! Open Me!") ' Since you passed in a variable for lngFlags, ' the function places the output flags value in the variable. Debug.Print Hex(lngFlags) End Function Private Function GetOpenFile(Optional varDirectory As Variant, _ Optional varTitleForDialog As Variant) As Variant ' Here's an example that gets an Access database name. Dim strFilter As String Dim lngFlags As Long Dim varFileName As Variant ' Specify that the chosen file must already exist, ' don't change directories when you're done ' Also, don't bother displaying ' the read-only box. It'll only confuse people. lngFlags = ahtOFN_FILEMUSTEXIST Or _ ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR If IsMissing(varDirectory) Then varDirectory = "" End If If IsMissing(varTitleForDialog) Then varTitleForDialog = "" End If ' Define the filter string and allocate space in the "c" ' string Duplicate this line with changes as necessary for ' more file templates. strFilter = ahtAddFilterItem(strFilter, _ "Access (*.mdb)", "*.MDB;*.MDA") ' Now actually call to get the file name. varFileName = ahtCommonFileOpenSave( _ OpenFile:=True, _ InitialDir:=varDirectory, _ Filter:=strFilter, _ Flags:=lngFlags, _ DialogTitle:=varTitleForDialog) If Not IsNull(varFileName) Then varFileName = TrimNull(varFileName) End If GetOpenFile = varFileName End Function Private Function ahtCommonFileOpenSave( _ Optional ByRef Flags As Variant, _ Optional ByVal InitialDir As Variant, _ Optional ByVal Filter As Variant, _ Optional ByVal FilterIndex As Variant, _ Optional ByVal DefaultExt As Variant, _ Optional ByVal FileName As Variant, _ Optional ByVal DialogTitle As Variant, _ Optional ByVal hwnd As Variant, _ Optional ByVal OpenFile As Variant) As Variant ' This is the entry point you'll use to call the common ' file open/save dialog. The parameters are listed ' below, and all are optional. ' ' In: ' Flags: one or more of the ahtOFN_* constants, OR'd together. ' InitialDir: the directory in which to first look ' Filter: a set of file filters, set up by calling ' AddFilterItem. See examples. ' FilterIndex: 1-based integer indicating which filter ' set to use, by default (1 if unspecified) ' DefaultExt: Extension to use if the user doesn't enter one. ' Only useful on file saves. ' FileName: Default value for the file name text box. ' DialogTitle: Title for the dialog. ' hWnd: parent window handle ' OpenFile: Boolean(True=Open File/False=Save As) ' Out: ' Return Value: Either Null or the selected filename Dim OFN As tagOPENFILENAME Dim strFileName As String Dim strFileTitle As String Dim fResult As Boolean ' Give the dialog a caption title. If IsMissing(InitialDir) Then InitialDir = CurDir If IsMissing(Filter) Then Filter = "" If IsMissing(FilterIndex) Then FilterIndex = 1 If IsMissing(Flags) Then Flags = 0& If IsMissing(DefaultExt) Then DefaultExt = "" If IsMissing(FileName) Then FileName = "" If IsMissing(DialogTitle) Then DialogTitle = "" If IsMissing(hwnd) Then hwnd = Application.hWndAccessApp If IsMissing(OpenFile) Then OpenFile = True ' Allocate string space for the returned strings. strFileName = Left(FileName & String(256, 0), 256) strFileTitle = String(256, 0) ' Set up the data structure before you call the function With OFN .lStructSize = Len(OFN) .hwndOwner = hwnd .strFilter = Filter .nFilterIndex = FilterIndex .strFile = strFileName .nMaxFile = Len(strFileName) .strFileTitle = strFileTitle .nMaxFileTitle = Len(strFileTitle) .strTitle = DialogTitle .Flags = Flags .strDefExt = DefaultExt .strInitialDir = InitialDir ' Didn't think most people would want to deal with ' these options. .hInstance = 0 '.strCustomFilter = "" '.nMaxCustFilter = 0 .lpfnHook = 0 'New for NT 4.0 .strCustomFilter = String(255, 0) .nMaxCustFilter = 255 End With ' This will pass the desired data structure to the ' Windows API, which will in turn it uses to display ' the Open/Save As Dialog. If OpenFile Then fResult = aht_apiGetOpenFileName(OFN) Else fResult = aht_apiGetSaveFileName(OFN) End If ' The function call filled in the strFileTitle member ' of the structure. You'll have to write special code ' to retrieve that if you're interested. If fResult Then ' You might care to check the Flags member of the ' structure to get information about the chosen file. ' In this example, if you bothered to pass in a ' value for Flags, we'll fill it in with the outgoing ' Flags value. If Not IsMissing(Flags) Then Flags = OFN.Flags ahtCommonFileOpenSave = TrimNull(OFN.strFile) Else ahtCommonFileOpenSave = vbNullString End If End Function Private Function ahtAddFilterItem(strFilter As String, _ strDescription As String, Optional varItem As Variant) As String ' Tack a new chunk onto the file filter. ' That is, take the old value, stick onto it the description, ' (like "Databases"), a null character, the skeleton ' (like "*.mdb;*.mda") and a final null character. If IsMissing(varItem) Then varItem = "*.*" ahtAddFilterItem = strFilter & _ strDescription & vbNullChar & _ varItem & vbNullChar End Function Private Function TrimNull(ByVal strItem As String) As String Dim intPos As Integer intPos = InStr(strItem, vbNullChar) If intPos > 0 Then TrimNull = Left(strItem, intPos - 1) Else TrimNull = strItem End If End Function Public Function cdlGetFile() As String On Error GoTo MyMistake Dim strFilter As String Dim strInputFileName As String strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*") strInputFileName = ahtCommonFileOpenSave(Filter:=strFilter, OpenFile:=True, _ DialogTitle:="Please select an input file...", _ Flags:=ahtOFN_HIDEREADONLY) If Len(strInputFileName) = 0 Then cdlGetFile = "No File" Else cdlGetFile = strInputFileName End If ExitError: Exit Function MyMistake: MsgBox "Source: " & Err.Source & (Chr(13) & Chr(10)) & "Description: " & Err.Description & (Chr(13) & Chr(10)) & "Error Number: " & "(" & Err.Number & ")", vbOKOnly, "Error" Resume ExitError End Function Public Function GetUniversal(ByVal strPath As String) As String Dim BufSize As Long Dim uni As UNIVERSAL_NAME_INFO Dim StartLoc As Long BufSize = UNIVERSAL_NAME_BUFFER_SIZE If WNetGetUniversalName(strPath, UNIVERSAL_NAME_INFO_LEVEL, uni, BufSize) = NO_ERROR Then 'After we return from WNetGetUniversalName, the lpUniversalName contains a pointer for the universal path name. 'The pointer is usually points to the first byte of the buffer array (buf variable in UNIVERSAL_NAME_INFO ). 'Just to be safe, I calculate the exact location of the string in the buffer, by the following expression: (The result is always 1) StartLoc = uni.lpUniversalName - VarPtr(uni) - 3 GetUniversal = Mid$(StrConv(uni.buf, vbUnicode), StartLoc, InStr(StrConv(uni.buf, vbUnicode), vbNullChar) - 1) Else MsgBox "Error: cannot find the universal path of " & strPath, vbOKOnly Or vbExclamation, "" End If End Function Private Function fGetDrives() As String 'Returns all mapped drives Dim lngRet As Long Dim strDrives As String * 255 Dim lngTmp As Long lngTmp = Len(strDrives) lngRet = GetLogicalDriveStrings(lngTmp, strDrives) fGetDrives = Left(strDrives, lngRet) End Function Private Function fGetUNCPath(strDriveLetter As String) As String On Local Error GoTo fGetUNCPath_Err Dim Msg As String, lngReturn As Long Dim lpszLocalName As String Dim lpszRemoteName As String Dim cbRemoteName As Long lpszLocalName = strDriveLetter lpszRemoteName = String$(255, Chr$(32)) cbRemoteName = Len(lpszRemoteName) lngReturn = WNetGetConnection(lpszLocalName, lpszRemoteName, _ cbRemoteName) Select Case lngReturn Case ERROR_BAD_DEVICE Msg = "Error: Bad Device" Case ERROR_CONNECTION_UNAVAIL Msg = "Error: Connection Un-Available" Case ERROR_EXTENDED_ERROR Msg = "Error: Extended Error" Case ERROR_MORE_DATA Msg = "Error: More Data" Case ERROR_NOT_SUPPORTED Msg = "Error: Feature not Supported" Case ERROR_NO_NET_OR_BAD_PATH Msg = "Error: No Network Available or Bad Path" Case ERROR_NO_NETWORK Msg = "Error: No Network Available" Case ERROR_NOT_CONNECTED Msg = "Error: Not Connected" Case NO_ERROR ' all is successful... End Select If Len(Msg) Then MsgBox Msg, vbInformation Else fGetUNCPath = Left$(lpszRemoteName, cbRemoteName) End If fGetUNCPath_End: Exit Function fGetUNCPath_Err: MsgBox Err.Description, vbInformation Resume fGetUNCPath_End End Function Private Function fDriveType(strDriveName As String) As String Dim lngRet As Long Dim strDrive As String lngRet = GetDriveType(strDriveName) Select Case lngRet Case DRIVE_UNKNOWN 'The drive type cannot be determined. strDrive = "Unknown Drive Type" Case DRIVE_ABSENT 'The root directory does not exist. strDrive = "Drive does not exist" Case DRIVE_REMOVABLE 'The drive can be removed from the drive. strDrive = "Removable Media" Case DRIVE_FIXED 'The disk cannot be removed from the drive. strDrive = "Fixed Drive" Case DRIVE_REMOTE 'The drive is a remote (network) drive. strDrive = "Network Drive" Case DRIVE_CDROM 'The drive is a CD-ROM drive. strDrive = "CD Rom" Case DRIVE_RAMDISK 'The drive is a RAM disk. strDrive = "Ram Disk" End Select fDriveType = strDrive End Function Public Function sListAllDrives() Dim strAllDrives As String Dim strTmp As String strAllDrives = fGetDrives If strAllDrives <> "" Then Do strTmp = Mid$(strAllDrives, 1, InStr(strAllDrives, vbNullChar) - 1) strAllDrives = Mid$(strAllDrives, InStr(strAllDrives, vbNullChar) + 1) Select Case fDriveType(strTmp) Case "Removable Media": Debug.Print "Removable drive : " & strTmp Case "CD ROM": Debug.Print " CD Rom drive : " & strTmp Case "Fixed Drive": Debug.Print " Local drive : " & strTmp Case "Network Drive": Debug.Print " Network drive : " & strTmp Debug.Print " UNC Path : " & _ fGetUNCPath(Left$(strTmp, Len(strTmp) - 1)) End Select Loop While strAllDrives <> "" End If End Function ************************************************************************** ************************************************************************** ************************************************************* You are receiving this mail because you subscribed to mso@xxxxxxxxxxxxx or MicrosoftOffice@xxxxxxxxxxxxxxxx To send mail to the group, simply address it to mso@xxxxxxxxxxxxx To Unsubscribe from this group, send an email to mso-request@xxxxxxxxxxxxx?Subject=unsubscribe Or, visit the group's homepage and use the dropdown menu. This will also allow you to change your email settings to digest or vacation (no mail). //www.freelists.org/webpage/mso To be able to use the files section for sharing files with the group, send a request to mso-moderators@xxxxxxxxxxxxx and you will be sent an invitation with instructions. Once you are a member of the files group, you can go here to upload/download files: http://www.smartgroups.com/vault/msofiles *************************************************************