' VBScript FileOpen dialogue.
' no special requirements. Tested up to Win11 22H2.

Dim Dlg, s
Set Dlg = new Dialogs

   '-- To provide for 1 or more file type filters just put the name followed by one or more file
   '-- extensions. The class with construct the filter as long as the paramter is formatted
   '-- like this comma-delimited sample: type, extension, type, extension, type, extension
   '-- ....etc. There can be any number of filters. Use "All Files, *" to also have a general filter
   '-- option that shows all files. If more than 1 extension applies to a file type, separate each
   '-- with a space, as done here with the "HTML Files" type.

s = Dlg.FileOpenDlg("Choose File", "", "Text Files, txt, All Files, *")

MsgBox s

Class Dialogs
Private Cls_Dlg, Cls_HTA, Cls_IE2

Public Function FileOpenDlg(Title, StartDir, sFilter) '-- openfiledlg([initFile as Variant][, initDir as Variant][, Filter as Variant][, Title as Variant])
    Dim Cls_Filter, Boo1, i2_c
       On Error Resume Next
     Boo1 = InitDlg()
        If Boo1 = False Then
              CleanUp
              Boo1 = InitDlg()  '-- sometimes the first init fails. ?? Reason unknown.
        End If
     If Boo1 = False Then Err.Raise 1, "Dialogs Class", "Failed to initialize HtmlDlgHelper object": Exit Function

     If Len(sFilter) > 0 Then
          Cls_Filter = GetFilterString(sFilter)
          FileOpenDlg = Cls_Dlg.openfiledlg(, CStr(StartDir), CStr(Cls_Filter), CStr(Title))
      Else
          FileOpenDlg = Cls_Dlg.openfiledlg(, CStr(StartDir), CStr("All Files(*.*)|*.*|"), CStr(Title))
      End If

       If Len(FileOpenDlg) = 0 Then Exit Function

          '--strange HTMLDlgHelper behavior. Returns a string ending with nulls.
          '-- The nulls won't affect using the string, but they will matter if you test the string.
          '-- For instance: If UCase(Right(s, 3)) = "TXT" Then ....   That won't work unless the nulls are snipped.
          '-- so check for nulls. If first null is first character that will return "". Otherwise there's a path string to
          '--  extract from the string buffer.
      i2_c = InStr(FileOpenDlg, Chr(0))
      If i2_c > 1 Then  FileOpenDlg = Left(FileOpenDlg, (i2_c - 1))

     CleanUp
 End Function

Private Function GetFilterString(sFilter)
  Dim A1, i2, s1
   On Error Resume Next
     A1 = Split(sFilter, ",")
        i2 = 0
     Do While i2 < UBound(A1)
         GetFilterString = GetFilterString & Trim(A1(i2))
            s1 = Trim(A1(i2 + 1))
            s1 = "*." & s1
            s1 = Replace(s1, " ", ";*.")
            GetFilterString = GetFilterString & "(" & s1 & ")|" & s1 & "|"
             i2 = i2 + 2
      Loop
End Function

Private Function InitDlg()
   Dim Cls_iCount, Cls_IE, Cls_SHAp
        '-- ugly hack required to get around problem of HTMLDlgHelper.HTMLDlgHelper being a control that needs to be sited.
     '-- it's also not marked as safe for scripting. This method dynamically creates an HTA, then gets the window.
     InitDlg = False
   CreateObject("WSCript.Shell").Run "MSHTA.EXE ""javascript:new ActiveXObject('InternetExplorer.Application').PutProperty('ID1', window);""", 0, False

     '-- Next step: go through open windows and retrieve the window object for just-created HTA.
    Set Cls_SHAp = CreateObject("Shell.Application")
    On Error Resume Next
     Cls_iCount = 1
          Do Until Cls_iCount = 10
             For Each Cls_IE In Cls_SHAp.Windows
                If IsObject(Cls_IE.GetProperty("ID1")) Then
                    Set Cls_IE2 = Cls_IE
                    Exit Do
                End If
             Next
                WScript.sleep 100
                Cls_iCount = Cls_iCount + 1
          Loop
      Set Cls_SHAp = Nothing '-- done with Shell.Application.
      If Not IsObject(Cls_IE2) Then Exit Function

      Set Cls_HTA = Cls_IE2.GetProperty("ID1")  '-- Cls_HTA is now an HTMLWindow2 object.
          '-- instantiate the HTMLDlgHelper.HTMLDlgHelper control.
      Cls_HTA.document.body.innerHTML = "<OBJECT ID=Dlg CLASSID=CLSID:3050F4E1-98B5-11CF-BB82-00AA00BDCE0B> </object>"
      Set Cls_Dlg = Cls_HTA.Dlg.Object  '-- get a reference to the control.
      Cls_IE2.quit  '-- this seems to be necessary, but if done elsewhere it may cause an odd lag of 4-5 seconds.

   If IsObject(Cls_Dlg) Then InitDlg = True
End Function

Private Sub CleanUp()
  On Error Resume Next
    Set Cls_Dlg = Nothing
   If IsObject(Cls_HTA) Then
      Cls_HTA.Close
      Set Cls_HTA = Nothing
   End If
   If IsObject(Cls_IE2) Then
      Cls_IE2.quit
      Set Cls_IE2 = Nothing
    End If
End Sub

  '-- this shouldn't be necessary because each HTA is closed after a call is made.
Private Sub Class_Terminate()
   CleanUp
End Sub

End Class