William Benson (VBACreations.Com)
vbacreations at gmail.com
Wed Jul 6 06:28:25 CDT 2011
If you put in a reference to Office 12.0 or Office 14.0, I think Access will find the opposite one on another user's machine. Then you can use the dialog. Below is code I wrote which will not require API and allows you to pass in strings for the file filter of this nature *.XL*|*.TXT|*.DAT|*.CSV and like items are grouped when it comes to the description. I quit after the most common file types. Also, I could have written a sort routine to put the detail items together in the filter, but I have not (yet). (text files: TXT, DAT, CSV) Function GetSelectedFile(Optional ExtensionStringWithPipeSeparator) As String Dim iFileTypes As Long Dim fDialog As Office.FileDialog Dim varFile As Variant Dim strTypes As String Dim strFilters As String Dim strTemp As String Dim strParseThis As String Dim ItemsSkipped() Dim strSkipped As String Dim i As Long strFilters = "" strTypes = "" ReDim ItemsSkipped(0) If Not IsMissing(ExtensionStringWithPipeSeparator) Then strParseThis = CStr(ExtensionStringWithPipeSeparator) Else strParseThis = "*.*" End If If strParseThis <> "*.*" Then Do Until InStr(strParseThis, "|") = 0 strTemp = Left(strParseThis, InStr(strParseThis, "|") - 1) strParseThis = Mid(strParseThis, Len(strTemp) + 2) strTemp = Replace$(strTemp, "*.", "") UpdateFilterAndType strTypes:=strTypes, strFilters:=strFilters, strTemp:=strTemp, ItemsSkipped:=ItemsSkipped Loop strTemp = Replace$(strParseThis, "*.", "") UpdateFilterAndType strTypes:=strTypes, strFilters:=strFilters, strTemp:=strTemp, ItemsSkipped:=ItemsSkipped Else strTypes = strTypes & ";*.*" strFilters = strFilters & ",All Files" End If If UBound(ItemsSkipped) > 0 Then strSkipped = "" For i = 1 To UBound(ItemsSkipped) strSkipped = strSkipped & Chr(13) & "'" & ItemsSkipped(i) & "'" Next strSkipped = Mid(strSkipped, 2) MsgBox "Known file Type List not comprehensive enough to accommodate extension(s):" & Chr(13) & Chr(13) & strSkipped End If If strTypes <> "" Then Set fDialog = Application.FileDialog(msoFileDialogFilePicker) fDialog.AllowMultiSelect = False fDialog.Title = "Select a file to examine" fDialog.Filters.Clear fDialog.Filters.Add Mid(strFilters, 2), Mid(strTypes, 2) If fDialog.Show <> True Then 'MsgBox "You clicked Cancel in the file dialog box." GoTo Exit_Me Else Set varFile = fDialog.SelectedItems GetSelectedFile = varFile(1) End If Else MsgBox "No Accepted File Types Were Specified!", vbInformation GetSelectedFile = "" End If Exit_Me: End Function Private Function UpdateFilterAndType(ByRef strTypes As String, ByRef strFilters As String, strTemp As String, ByRef ItemsSkipped) If InStr(UCase(strTemp), "DOC") > 0 Then If InStr(UCase(strFilters), "DOC") = 0 Then strFilters = strFilters & "," & "Doc" End If ElseIf InStr(UCase(strTemp), "RTF") > 0 Then If InStr(UCase(strFilters), "DOC") = 0 Then strFilters = strFilters & "," & "Doc" End If ElseIf InStr(UCase(strTemp), "PDF") > 0 Then strFilters = strFilters & "," & "Pdf" ElseIf InStr(UCase(strTemp), "MD") > 0 Then strFilters = strFilters & "," & "Acc" ElseIf InStr(UCase(strTemp), "XL") > 0 Then If InStr(UCase(strFilters), "SSHT") = 0 Then strFilters = strFilters & "," & "Ssht" End If ElseIf InStr(UCase(strTemp), "WK") > 0 Then If InStr(UCase(strFilters), "SSHT") = 0 Then strFilters = strFilters & "," & "Ssht" End If ElseIf InStr(UCase(strTemp), "TXT") > 0 Then If InStr(UCase(strFilters), "TEXT") = 0 Then strFilters = strFilters & "," & "Text" End If ElseIf InStr(UCase(strTemp), "CSV") > 0 Then If InStr(UCase(strFilters), "TEXT") = 0 Then strFilters = strFilters & "," & "Text" End If ElseIf InStr(UCase(strTemp), "LOG") > 0 Then If InStr(UCase(strFilters), "TEXT") = 0 Then strFilters = strFilters & "," & "Text" End If ElseIf InStr(UCase(strTemp), "DAT") > 0 Then If InStr(UCase(strFilters), "TEXT") = 0 Then strFilters = strFilters & "," & "Text" End If Else If UBound(ItemsSkipped) = 0 Then ReDim ItemsSkipped(1) Else ReDim Preserve ItemsSkipped(UBound(ItemsSkipped) + 1) End If ItemsSkipped(UBound(ItemsSkipped)) = strTemp GoTo Exit_Me End If strTypes = strTypes & ";" & "*." & LCase(strTemp) Exit_Me: End Function