[AccessD] "Modern" replacement for CommonDlg

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