Option Explicit If MsgBox("This script will run until system shutdown downloading dropped URLs. Okay to continue?", vbYesNo) = vbYes Then Main End If Sub Main Dim strUrlPath, strUrl, strFilePath, strFile Dim fils, fil, fs, ts Const ForReading = 1 'Create objects Set fs = CreateObject("Scripting.FileSystemObject") 'Get the directory name where the user will drop internet shortcuts strUrlPath = BrowseForFolder("Where will you drop the URLs?") If strUrlPath = "" Then Exit Sub If Not fs.FolderExists(strUrlPath) Then Exit Sub 'Get the directory name where we should store downloaded files strFilePath = BrowseForFolder("Where should I store the files?") If strFilePath = "" Then Exit Sub If Not fs.FolderExists(strFilePath) Then Exit Sub 'Let WSCRIPT users know we didn't just go away CreateObject("WScript.Shell").Popup "Program is running!", 5 Set fils = fs.GetFolder(strUrlPath).Files Do For Each fil In fils If Lcase(Right(fil.Path, 4)) = ".url" Then Set ts = fs.OpenTextFile(fil.Path, ForReading) strUrl = ts.ReadAll ts.Close If InStr(strUrl, "http://") <> 0 Then strUrl = Mid(strUrl, InStr(strUrl, "http://")) If InStr(strUrl, vbCr) <> 0 Then strUrl = Left(strUrl, InStr(strUrl, vbCr) - 1) End If If InStr(strUrl, vbLf) <> 0 Then strUrl = Left(strUrl, InStr(strUrl, vbLf) - 1) End If strFile = Mid(strUrl, InStrRev(strUrl, "/") + 1) Status strFile If SaveWebBinary(strUrl, fs.BuildPath(strFilePath, strFile)) Then Status ".... Done!" & vbCrLf fs.DeleteFile fil.Path Else Status ".... FAILED" & vbCrLf End If End If End If Next Wscript.Sleep 5000 Loop End Sub Sub Status (strMessage) 'If the program was run with CSCRIPT, this writes a 'line into the DOS box. If run with WSCRIPT, it does nothing. If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then Wscript.Echo strMessage End If End Sub Function SaveWebBinary(strUrl, strFile) 'As Boolean Const adTypeBinary = 1 Const adSaveCreateOverWrite = 2 Const ForWriting = 2 Dim web, varByteArray, strData, strBuffer, lngCounter, ado On Error Resume Next 'Download the file with any available object Err.Clear Set web = Nothing Set web = CreateObject("WinHttp.WinHttpRequest.5.1") If web Is Nothing Then Set web = CreateObject("WinHttp.WinHttpRequest") If web Is Nothing Then Set web = CreateObject("MSXML2.ServerXMLHTTP") If web Is Nothing Then Set web = CreateObject("Microsoft.XMLHTTP") web.Open "GET", strURL, False web.Send If Err.Number <> 0 Then SaveWebBinary = False Set web = Nothing Exit Function End If If web.Status <> "200" Then SaveWebBinary = False Set web = Nothing Exit Function End If varByteArray = web.ResponseBody Set web = Nothing 'Now save the file with any available method On Error Resume Next Set ado = Nothing Set ado = CreateObject("ADODB.Stream") If ado Is Nothing Then Set fs = CreateObject("Scripting.FileSystemObject") Set ts = fs.OpenTextFile(strFile, ForWriting, True) strData = "" strBuffer = "" For lngCounter = 0 to UBound(varByteArray) ts.Write Chr(255 And Ascb(Midb(varByteArray,lngCounter + 1, 1))) Next ts.Close Else ado.Type = adTypeBinary ado.Open ado.Write varByteArray ado.SaveToFile strFile, adSaveCreateOverWrite ado.Close End If SaveWebBinary = True End Function Function BrowseForFolder(strPrompt) 'Uses the "Shell.Application" (only present in Win98 and newer) 'to bring up a file/folder selection window. Falls back to an 'ugly input box under Win95. 'Shell32.ShellSpecialFolderConstants Const ssfPERSONAL = 5 'My Documents Const ssfDRIVES = 17 'My Computer Const SFVVO_SHOWALLOBJECTS = 1 Const SFVVO_SHOWEXTENSIONS = 2 Dim sh, fol, fs, lngView, strPath Set sh = CreateObject("Shell.Application") If Instr(TypeName(sh), "Shell") = 0 Then BrowseForFolder = InputBox(strPrompt, "Select Folder", CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName)) Exit Function End If Set fs = CreateObject("Scripting.FileSystemObject") lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS strPath = "" Set fol = sh.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES) Err.Clear On Error Resume Next strPath = fol.ParentFolder.ParseName(fol.Title).Path 'An error occurs if the user selects a drive instead of a folder If Err.Number <> 0 Then BrowseForFolder = Left(Right(fol.Title, 3), 2) & "\" Else BrowseForFolder = strPath End If End Function