'Uses the Windows shell where available. If the 
'shell object isn't there, falls back to using Excel. 
'If Excel isn't there, falls back to using IE 
'in order to pop up a file selection dialog. If that 
'isn't available, falls back to using an ordinary 
'text input box.

MsgBox "You selected:" & vbCrLf & BrowseForFile("Select a File:", "Select File")


Function BrowseForFile(strPrompt, strTitle)
	On Error Resume Next
	If Instr(TypeName(CreateObject("Shell.Application")), "Shell") = 0 Then
		If Instr(TypeName(CreateObject("Excel.Application")), "Application") = 0 Then
			If Instr(TypeName(CreateObject("InternetExplorer.Application")), "Browser") = 0 Then
				BrowseForFile = InputBox(strPrompt, strTitle, WScript.ScriptFullName)
			Else
				BrowseForFile = BrowseForFile_Htm(strPrompt, strTitle)
			End If
		Else
			BrowseForFile = BrowseForFile_Excel(strTitle)
		End If
	Else
		BrowseForFile = BrowseForFile_Shell(strPrompt)
	End If
End Function

Function BrowseForFile_Shell(strPrompt)
'Uses the "Shell.Application" (only present in Win98 and newer)
'to bring up a file/folder selection window. Note: this code
'*will* allow the user to select a folder! A folder selection
'is easily detected if you read the comments in the code.
'Shell32.ShellSpecialFolderConstants
Const ssfDESKTOP = 0 'Desktop (including system items)
Const ssfPROGRAMS = 2 'Programs section of Start Menu
Const ssfCONTROLS = 3 'Control Panel (no path)
Const ssfPRINTERS = 4 'Printers (no path)
Const ssfPERSONAL = 5 'My Documents
Const ssfFAVORITES = 6 'IE Favorites
Const ssfSTARTUP = 7 'Startup
Const ssfRECENT = 8 'Recent
Const ssfSENDTO = 9 'SendTo
Const ssfBITBUCKET = 10 'Recycle Bin (no path)
Const ssfSTARTMENU = 11 'Start Menu
Const ssfDESKTOPDIRECTORY = 16 'Desktop directory (no system items)
Const ssfDRIVES = 17 'My Computer
Const ssfNETWORK = 18 'Network Neighborhood
Const ssfNETHOOD = 19
Const ssfFONTS = 20
Const ssfTEMPLATES = 21 'The ShellNew directory
Const ssfCOMMONSTARTMENU = 22 'All users start menu
Const ssfCOMMONPROGRAMS = 23
Const ssfCOMMONSTARTUP = 24
Const ssfCOMMONDESKTOPDIR = 25
Const ssfAPPDATA = 26 'Application Data directory
Const ssfPRINTHOOD = 27
Const ssfLOCALAPPDATA = 28
Const ssfALTSTARTUP = 29
Const ssfCOMMONALTSTARTUP = 30
Const ssfCOMMONFAVORITES = 31 'All Users Favorites
Const ssfINTERNETCACHE = 32 'Temporary Internet Files
Const ssfCOOKIES = 33 'Cookies
Const ssfHISTORY = 34 'History (no path)
Const ssfCOMMONAPPDATA = 35
Const ssfWINDOWS = 36
Const ssfSYSTEM = 37
Const ssfPROGRAMFILES = 38
Const ssfMYPICTURES = 39
Const ssfPROFILE = 40
Const ssfSYSTEMx86 = 41
Const ssfPROGRAMFILESx86 = 48

Const SFVVO_SHOWALLOBJECTS = 1 'Blocks display of non-file items
Const SFVVO_SHOWEXTENSIONS = 2 'Changes inside prompt to "Select a File"
Const SFVVO_SHOWCOMPCOLOR = 8
Const SFVVO_SHOWSYSFILES = 32
Const SFVVO_WIN95CLASSIC = 64
Const SFVVO_DOUBLECLICKINWEBVIEW = 128
Const SFVVO_DESKTOPHTML = 512
Const SFVVO_SHOWFILES = 16384 'Displays files

	Dim sh, fol, fs, lngView, strPath
	Set sh = CreateObject("Shell.Application")
	Set fs = CreateObject("Scripting.FileSystemObject")
	lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS Or SFVVO_SHOWFILES
	strPath = ""
	Set fol = sh.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
	On Error Resume Next
	'The following line will only work if the user selected a FOLDER instead of a FILE
	strPath = fol.ParentFolder.ParseName(fol.Title).Path
	'If the user selected a file, we must get that file's parent so we can
	'work with it's path (since these functions only work on folders).
	If strPath = "" Then
		strPath = fol.Title
		Set fol = fol.ParentFolder
		strPath = fs.BuildPath(fol.ParentFolder.ParseName(fol.Title).Path, strPath)
	End If
	BrowseForFile_Shell = strPath
End Function


Function BrowseForFile_Excel(strTitle)
Dim xl 'As Excel.Application
	Set xl = CreateObject("Excel.Application")
	BrowseForFile_Excel = xl.GetOpenFilename(, , strTitle)
End Function


Function BrowseForFile_Htm(strPrompt, strTitle)
'Uses the HTML file upload form as a file selection tool.
Dim fs, web, doc
Dim strFile, strChoice
Dim intChars
Dim dtTime
	On Error Resume Next
	Set web = CreateObject("InternetExplorer.Application")
	If web Is Nothing Then
		BrowseForFile_Htm = ""
		Exit Function
	End If
	web.Width = 300
	web.Height = 175
	web.Offline = True
	web.AddressBar = False
	web.MenuBar = False
	web.StatusBar = False
	web.Silent = True
	web.ToolBar = False
	web.Navigate "about:blank"
	'Wait for the browser to navigate to nowhere
	dtTime = Now
	Do While web.Busy
		'Don't wait more than 5 seconds
		Wscript.Sleep 100
		If (dtTime + 5/24/60/60) < Now Then
			BrowseForFile_Htm = ""
			web.Quit
			Exit Function
		End If
	Loop
	'Wait for a good reference to the browser document
	Set doc = Nothing
	dtTime = Now
	Do Until Not doc Is Nothing
		Wscript.Sleep 100
		Set doc = web.Document
		'Don't wait more than 5 seconds
		If (dtTime + 5/24/60/60) < Now Then
			BrowseForFile_Htm = ""
			web.Quit
			Exit Function
		End If
	Loop
	'Write the HTML form
	doc.Write "<html><head><title>" & strTitle & "</title></head>"
	doc.Write "<body><b>" & strPrompt & "</b><br><form><input type=file name=filename>"
	doc.Write "</select>"
	doc.Write "<br><br><input type=button "
	doc.Write "name=submit "
	doc.Write "value=""OK"" onclick='javascript:submit.value=""Done""'>"
	doc.Write "</form></body></html>"
	'Show the form
	web.Visible = True
	'Wait for the user to choose, but fail gracefully if a popup killer.
	Err.Clear
	Do Until doc.Forms(0).elements("submit").Value <> "OK"
		Wscript.Sleep 100
		If doc Is Nothing Then
			BrowseForFile_Htm = ""
			web.Quit
			Exit Function
		End If
		If Err.Number <> 0 Then
			BrowseForFile_Htm = ""
			web.Quit
			Exit Function
		End If
	Loop
	'Retrieve the chosen value
	BrowseForFile_Htm = doc.Forms(0).elements("filename").Value
	web.Quit
End Function