WSH OpenFileDialog für Windows 7 und höher

Da es mit dem "UserAccounts.CommonDialog"-Objekt seit Windows 7 nicht mehr geht eine kleiner Umweg durch eine HTA-Datei und Input-Field vom Typ File.

 

Option Explicit
MsgBox openfileDialog

Function openfileDialog()
  Dim fs, wsh, f
  Dim s, sTmp, sTxt, sHTA
  On Error Resume Next
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set wsh = CreateObject("WScript.Shell")
  sTmp = wsh.ExpandEnvironmentStrings("%temp%") & "\~filedialog."
  sTxt = sTmp & "txt"
  sHTA = sTmp & "hta"
  Set f = fs.OpenTextFile(sHTA, 2, True)
  s = "<html><head><HTA:APPLICATION BORDER=""none""></head><SCRIPT LANGUAGE=""VBScript"">" & vbCrLf & _
      "Sub Window_onLoad" & vbCrLf & _
      "Dim st, sp, f, fs, wsh" & vbCrLf & _
      "window.resizeTo 1, 1" & vbCrLf & _
      "fd.click" & vbCrLf & _
      "sp = fd.Value" & vbCrLf & _
      "If sp <> vbNullString Then" & vbCrLf & _
      "Set wsh = CreateObject(""WScript.Shell"")" & vbCrLf & _
      "Set fs = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
      "Set f = fs.OpenTextFile(""" & sTxt & """, 2, True)" & vbCrLf & _
      "f.write sp" & vbCrLf & _
      "f.close" & vbCrLf & _
      "Set fs = Nothing" & vbCrLf & _
      "Set wsh = Nothing" & vbCrLf & _
      "End If" & vbCrLf & _
      "self.close" & vbCrLf & _
      "End Sub" & vbCrLf & _
      "</SCRIPT>" & vbCrLf & _
      "<body><fieldset><input name=""fd"" type=""file"" id=""fd"" class=""invisible""></fieldset></body>"
  
  f.write s
  f.Close
  wsh.Run sHTA, 1, True
  Set f = fs.OpenTextFile(sTxt, 1, True)
  openfileDialog = f.readline
  f.Close
  Set fs = Nothing
  wsh.Run wsh.ExpandEnvironmentStrings("%COMSPEC%") & " /C DEL /q /f " & sTmp & "*"
  Set fs = Nothing
  Set wsh = Nothing
End Function

 

Hauptmenü

Anmeldeformular