'Directly saves any media file and can indirectly save some '(videos) from their presentation URL. Option Explicit Dim gintFileNameType, xmlDom, node, strUrl 'Assume original URL of http://foo.com/video?id=123 which redirects to http://foo.com/movies/test.flv Const FILE_NAME_ORIGINAL = 0 'would save as "foo.com-video-id=123.flv" Const FILE_NAME_FINAL = 1 'would save as "foo.com-movies-test.flv" '********************* USER EDITABLE AREA ********************************* gintFileNameType = FILE_NAME_ORIGINAL Const KEEP_MACHINE_NAME = True 'Keep the "videos" in "videos.foo.com" or just use "foo.com"? Machine "www" is NEVER kept. Const DEBUG_MESSAGES = True 'Verbose status messages (if running under CSCRIPT) Const CONTENT_TYPES = "video/ image/ audio/ application/" 'space-delimted list of target mime type headers Const RIGHT_CLICK_TEXT = "Paste URL Content Here" '********************* END OF USER EDITABLE AREA ************************** Main Sub Main() Dim fs Dim strUrl, strOriginalUrl, strNewUrl Dim strFileName, strFilePath Dim strMimeHeader, strMimeType 'Initialize Set fs = CreateObject("Scripting.FileSystemObject") 'Do we have a destination argument? If WScript.Arguments.Count = 0 Then 'If we have nothing, toggle the right-click registration and show the help. ToggleRightClick ShowHelp Exit Sub End If If Not fs.FolderExists(WScript.Arguments(0)) Then ShowHelp Exit Sub Else strFilePath = WScript.Arguments(0) End If 'Do we have a good URL? strOriginalUrl = GetClipboard() 'Make sure whatever was in the clipboard is long enough to be a URL If Len(strOriginalUrl) < 12 Then ToggleRightClick ShowHelp Exit Sub Else 'Make sure the candidate URL starts with HTTP If Left(strOriginalUrl, 7) <> "http://" Then ToggleRightClick ShowHelp Exit Sub End If End If 'Read the XML settings file and load it into the global xmlDom object. If Not GetXml() Then If DEBUG_MESSAGES Then Status "Unable to read local XML file" 'Try loading known good XML from the web If Not xmlDom.loadXML(XmlConfig()) Then If DEBUG_MESSAGES Then Status "Unable to read web XML data" 'If nothing works, scream for help MsgBox "Fatal Error - Can't load XML configuration" Exit Sub End If End If 'Check the first step strUrl = strOriginalUrl Set node = Nothing On Error Resume Next Set node = xmlDom.SelectSingleNode("//sites/site/name[text()='" & DomainName(strUrl) & "']").parentNode On Error Goto 0 If node Is Nothing Then If DEBUG_MESSAGES Then Status "CAUTION: No local configuration data for " & DomainName(strUrl) End If If (("" = xml("start1")) Or ("" = xml("start1"))) Then If DEBUG_MESSAGES Then Status "CAUTION: Configuration data for " & DomainName(strUrl) & " is incomplete" End If strNewUrl = ProcessURL(strUrl, xml("start1"), xml("stop1")) 'Sometimes the returned URL needs to be massaged a bit... If xml("search1") <> "" Then strNewUrl = Replace(strNewUrl, xml("search1"), xml("replace1")) End If 'Take a look at what we have Select Case strNewUrl Case "" 'We should quit, but maybe we're already at a playlist page. If DEBUG_MESSAGES Then Status "No first pointer text found" Case strUrl 'Download it SaveFile strFilePath, strUrl, strOriginalUrl Exit Sub Case Else 'We must have a new URL. Go to the next step. strUrl = strNewUrl End Select 'Check the second step Set node = Nothing On Error Resume Next Set node = xmlDom.SelectSingleNode("//sites/site/name[text()='" & DomainName(strUrl) & "']").parentNode On Error Goto 0 If node Is Nothing Then If DEBUG_MESSAGES Then Status "CAUTION: No configuration data for " & DomainName(strUrl) End If strNewUrl = ProcessURL(strUrl, xml("start2"), xml("stop2")) 'Sometimes the returned URL needs to be massaged a bit... If xml("search2") <> "" Then strNewUrl = Replace(strNewUrl, xml("search2"), xml("replace2")) End If Select Case strNewUrl Case "" 'Quit. Or do nothing. Same thing. If DEBUG_MESSAGES Then Status "No second pointer text found" Case strUrl 'Download it SaveFile strFilePath, strUrl, strOriginalUrl Exit Sub Case Else 'We must have a new URL. Go to the last step. strUrl = strNewUrl End Select 'Final step is to download strMimeType = ContentType(strUrl) If DEBUG_MESSAGES Then Status "Mime Type: " & strMimeType If strMimeType <> "" Then For Each strMimeHeader In Split(CONTENT_TYPES) If InStr(strMimeType, strMimeHeader) = 1 Then 'Download it SaveFile strFilePath, strUrl, strOriginalUrl Exit Sub End If Next If DEBUG_MESSAGES Then Status strMimeType & ": No matching mime type" Else If DEBUG_MESSAGES Then Status "No mime type information - Assume good!" 'Download it SaveFile strFilePath, strUrl, strOriginalUrl Exit Sub End If End If End Sub Function GetXml() On Error Resume Next Set xmlDom = Nothing If xmlDom Is Nothing Then Set xmlDom = CreateObject("Msxml2.DOMDocument.4.0") If xmlDom Is Nothing Then Set xmlDom = CreateObject("Msxml2.DOMDocument") If xmlDom Is Nothing Then Set xmlDom = CreateObject("Msxml2.XMLDocument") If xmlDom Is Nothing Then Set xmlDom = CreateObject("Msxml.DOMDocument") If xmlDom Is Nothing Then Set xmlDom = CreateObject("Microsoft.XMLDOM") On Error Goto 0 xmlDom.async = False GetXml = xmlDom.load(FileNameLikeMine("xml")) End Function Function xml(strQuery) Dim strXml strXml = "" On Error Resume Next strXml = UrlDecode(node.selectSingleNode(strQuery).Text) 'xmlDom.selectSingleNode(strQuery).Text On Error Goto 0 xml = strXml End Function Sub SaveFile(strFilePath, strUrl, strOriginalUrl) Dim fs, strFileName, strCookie, strExtension Set fs = CreateObject("Scripting.FileSystemObject") 'Take a guess at the file extension in case the URL doesn't have one strExtension = ContentType(strUrl) strExtension = MimeExtension(strExtension) If strExtension = "" Then strExtension = fs.GetExtensionName(UrlToFileName(strUrl)) End If 'What will we use as a source for the base file name Select Case gintFileNameType Case FILE_NAME_ORIGINAL strFileName = UrlToFileName(strOriginalUrl) 'If the extension doesn't match the mime, add it If ((Len(strExtension) > 0) And (Len(strExtension) < 5)) Then If Lcase(Right(strFileName, Len(strExtension))) <> Lcase(strExtension) Then strFileName = strFileName & "." & strExtension End If End If Case FILE_NAME_FINAL strFileName = UrlToFileName(strUrl) End Select 'If the file name doesn't have an extension, add one If ((Len(strExtension) > 0) And (Len(strExtension) < 5)) Then If Instr(Right(strFileName, 5), ".") = 0 Then strFileName = strFileName & "." & strExtension End If End If strFileName = fs.BuildPath(strFilePath, strFileName) If DEBUG_MESSAGES Then Status "SaveFile Name: " & strFileName 'No complex cookie handling, but make some small effort to validate ourselves If DomainName(strUrl) = DomainName(strOriginalUrl) Then strCookie = GetCookie(strOriginalUrl) Else strCookie = "" End If SaveWebBinary strUrl, strFileName, strCookie End Sub Function MimeExtension(strMimeType) 'Returns the likely file extension for a given mime type. Returns empty string if unknown. Dim strMimeExtension, dic Const MIME_DATA = "application/x-compress,z|application/x-compressed,tgz|application/x-dvi,dvi|application/x-gtar,gtar|application/x-gzip,gz|application/x-iphone,iii|application/x-javascript,js|application/x-shockwave-flash,swf|application/x-stuffit,sit|application/x-tar,tar|application/zip,zip|audio/basic,au|audio/mid,mid|audio/mpeg,mp3|audio/x-mpegurl,m3u|audio/x-pn-realaudio,ra|audio/x-wav,wav|audio/x-ms-wma,wma|image/bmp,bmp|image/gif,gif|image/jpeg,jpg|image/png,png|image/svg+xml,svg|image/tiff,tiff|image/x-icon,ico|image/x-portable-anymap,pnm|image/x-portable-bitmap,pbm|image/x-portable-graymap,pgm|image/x-portable-pixmap,ppm|image/x-rgb,rgb|image/x-xbitmap,xbm|image/x-xpixmap,xpm|image/x-xwindowdump,xwd|video/mpeg,mpg|video/quicktime,mov|video/x-ms-asf,asf|video/x-msvideo,avi|video/x-ms-wmv,wmv|video/x-flv,flv|video/x-sgi-movie,movie|video/mp4,mp4" Set dic = CreateDictionary(MIME_DATA, ",", "|") If dic.Exists(strMimeType) Then strMimeExtension = dic.Item(strMimeType) Else strMimeExtension = "" End If MimeExtension = strMimeExtension End Function Function CreateDictionary(strMultiplyDelimitedString, strItemSeparator, strEntrySeparator) 'As Scripting.Dictionary 'Accepts a multiply-delimited string and returns a dictionary. For example 'Set dict=CreateDictionary("counts=9.3&name=Eric Phelps", "=", "&") becomes available like this... 'dict.Item("counts") will return "9.3", and dict.Item("name") returns "Eric Phelps". 'Likewise dict.Exists("counts") is True and dict.Exists("xyftc") is False. Dim strQuery 'As String Dim strName 'As String Dim strValue 'As String Dim dict 'As Object Set dict = CreateObject("Scripting.Dictionary") strQuery = strMultiplyDelimitedString Do While strQuery <> "" strName = Left(strQuery, InStr(strQuery, strItemSeparator) - 1) strQuery = Mid(strQuery, InStr(strQuery, strItemSeparator) + Len(strItemSeparator)) If InStr(strQuery, strEntrySeparator) = 0 Then strValue = strQuery strQuery = "" Else strValue = Left(strQuery, InStr(strQuery, strEntrySeparator) - 1) strQuery = Mid(strQuery, InStr(strQuery, strEntrySeparator) + Len(strEntrySeparator)) End If 'Allow for multiple items by tab-delimiting them If dict.Exists(strName) Then dict.Item(strName) = dict.Item(strName) & vbTab & strValue Else dict.Add strName, strValue End If Loop Set CreateDictionary = dict Set dict = Nothing End Function Sub WriteLog(strText) Dim fs, strName Set fs = CreateObject("Scripting.FileSystemObject") strName = fs.GetBaseName(WScript.ScriptName) strName = FileNameInTempDir(strName & ".log") AppendToFile strText, strName End Sub Function String2File(strData, strFileName) 'Writes a string to a file. Returns True if success. Dim fs 'As Scripting.FileSystemObject Dim ts 'As Scripting.TextStream Dim lngChar, strBlock, intChar, dtTimeStamp Const ForWriting = 2 Set fs = CreateObject("Scripting.FileSystemObject") On Error Resume Next If fs.FileExists(strFileName) Then dtTimeStamp = fs.GetFile(strFileName).DateLastModified Else dtTimeStamp = CDate(0) End If Err.Clear Set ts = fs.OpenTextFile(strFileName, ForWriting, True) ts.Write strData If Err.Number <> 0 Then 'Must have hit one of the "problem characters" between 128 and 159 For lngChar = 1 To Len(strData) Step 100 Err.Clear ts.Write Mid(strData, lngChar, 100) If Err.Number <> 0 Then 'This block of 100 must have the problem. Write them one-at-a-time strBlock = Mid(strData, lngChar, 100) For intChar = 1 To Len(strBlock) ts.Write Chr(255 And AscW(Mid(strBlock, intChar))) Next End If Next End If ts.Close If fs.FileExists(strFileName) Then If dtTimeStamp = fs.GetFile(strFileName).DateLastModified Then String2File = False Else String2File = True End If Else String2File = False End If End Function Sub AppendToFile(strText, strFile) Dim fs 'As Scripting.FileSystemObject Dim ts 'As Scripting.TextStream Dim lngChar, strBlock, intChar Const ForAppending = 8 Set fs = CreateObject("Scripting.FileSystemObject") Set ts = fs.OpenTextFile(strFile, ForAppending, True) Err.Clear On Error Resume Next ts.Write strText If Err.Number <> 0 Then 'Must have hit one of the "problem characters" between 128 and 159 For lngChar = 1 To Len(strText) Step 100 Err.Clear ts.Write Mid(strText, lngChar, 100) If Err.Number <> 0 Then 'This block of 100 must have the problem. Write them one-at-a-time strBlock = Mid(strText, lngChar, 100) For intChar = 1 To Len(strBlock) ts.Write Chr(255 And AscW(Mid(strBlock, intChar))) Next End If Next End If ts.Close On Error Goto 0 End Sub Function FileNameInTempDir(strFileName) 'As String 'Returns the full path and file name to a file in the user's temporary directory Dim fs 'As Scripting.FileSystemObject Const TemporaryFolder = 2 Set fs = CreateObject("Scripting.FileSystemObject") FileNameInTempDir = fs.GetAbsolutePathName(fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder), strFileName)) End Function Function FileNameLikeMine(strFileExtension) 'As String 'Returns a file name the same as the script name except 'for the file extension. Dim fs 'As Object Dim strExtension 'As String Set fs = CreateObject("Scripting.FileSystemObject") strExtension = strFileExtension If Len(strExtension) < 1 Then strExtension = "txt" If strExtension = "." Then strExtension = "txt" If Left(strExtension,1) = "." Then strExtension = Mid(strExtension, 2) FileNameLikeMine = Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & strExtension End Function Function GetCookie(strUrl) Dim web, strCookie On Error Resume Next 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("Msxml2.XMLHTTP") If web Is Nothing Then Set web = CreateObject("Microsoft.XMLHTTP") web.Open "HEAD", strUrl, False web.SetRequestHeader "REFERER", strUrl web.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" web.SetRequestHeader "Accept", "text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5" web.SetRequestHeader "Accept-Language", "en-us,en;q=0.5" web.SetRequestHeader "Accept-Charset", "ISO-8859-1,utf-8;q=0.7,*;q=0.7" web.Send 'Sometimes self-referring can cause problems. If so, try it without the referral. If Left(web.Status, 2) = "40" Then web.SetRequestHeader "REFERER", Null web.send End If strCookie = web.getResponseHeader("Set-Cookie") strCookie = Split(strCookie, ";")(0) GetCookie = strCookie End Function Function DomainName(strUrl) 'Converts "http://machine.site.com/foo.txt" to "site.com" Dim strTemp, strName, strTld strTemp = strUrl 'Now at "http://machine.site.com/foo.txt" If InStr(1, strTemp, "http://", vbTextCompare) = 1 Then strTemp = Mid(strTemp, 8) 'Now at "machine.site.com/foo.txt" strTemp = Split(strTemp, "/")(0) 'Now at "machine.site.com" strTld = Split(strTemp, ".")(UBound(Split(strTemp, "."))) 'Got the "com" part strName = Split(strTemp, ".")(UBound(Split(strTemp, ".")) - 1) 'Got the "site" part DomainName = strName & "." & strTld End Function Function UrlToFileName(strUrl) 'Takes a URL like "http://www.bar.com/movies/test.flv" and returns a file name like "bar.com-movies-test.flv" Const BAD_CHARS = "\ / : * ? < > |" Dim strName, strChar strName = strUrl If InStr(1, strName, "http://", vbTextCompare) = 1 Then strName = Mid(strName, 8) strName = Replace(strName, "//", "/") If DEBUG_MESSAGES Then Status "Name: " & strName 'We will always ignore the common "www" machine name If InStr(1, strName, "www.", vbTextCompare) = 1 Then strName = Mid(strName, 5) If Not KEEP_MACHINE_NAME Then If Not IsNumeric(Split(strName, ".")(0)) Then 'Don't treat IP address like machine.domain strName = Mid(strName, Instr(strName, Split(Split(strName, "/")(0), ".")(Ubound(Split(Split(strName, "/")(0), ".")) - 1))) If DEBUG_MESSAGES Then Status "Name: " & strName End If End If strName = UnEscape(strName) 'Replace bad characters with dashes For Each strChar In Split(BAD_CHARS) strName = Replace(strName, strChar, "-") Next If DEBUG_MESSAGES Then Status "Name: " & strName UrlToFileName = strName End Function Function UrlDecode(strText) 'As String Dim strBuffer 'As String Dim lngPosition 'As Long For lngPosition = 1 To Len(strText) If Mid(strText, lngPosition, 1) = "%" Then strBuffer = strBuffer & Chr("&H" & Mid(strText, lngPosition + 1, 2)) lngPosition = lngPosition + 2 Else strBuffer = strBuffer & Mid(strText, lngPosition, 1) End If Next UrlDecode = strBuffer End Function Function ProcessURL(strUrl, strBeginURL, strEndURL) 'Reads the page or header from a URL and returns a redirect URL from it. 'Returns the exact URL if the file should be downloaded. 'Returns an empty string if redirect URL can't be read. 'Uses global CONTENT_TYPES, functions GetRedirect, GetData Dim strLocation, strMimeType, strDocument, strProcessURL, strMimeHeader, blnGoodURL 'Assign a new name so we don't modify the input (I don't like ByVal) strProcessURL = strUrl If DEBUG_MESSAGES Then Status "Processing: " & strProcessURL 'Remove any double slashes. Don't know why they happen, but they do. strProcessURL = Left(strProcessURL, 7) & Replace(Mid(strProcessURL, 8), "//", "/") 'Follow redirects Do strLocation = GetRedirect(strProcessURL) If strLocation = "" Then Exit Do Else ProcessURL = strLocation If DEBUG_MESSAGES Then Status "Redirected: " & strProcessURL End If Loop 'Check content type strMimeType = ContentType(strProcessURL) If DEBUG_MESSAGES Then Status "Mime Type: " & strMimeType For Each strMimeHeader In Split(CONTENT_TYPES) If InStr(strMimeType, strMimeHeader) = 1 Then ProcessURL = strProcessURL If DEBUG_MESSAGES Then Status "Mime type MATCHED: " & strMimeHeader Exit Function End If Next 'Get page content strDocument = GetData(strProcessURL) If DEBUG_MESSAGES Then Status "Retrieved: " & Len(strDocument) & " bytes" 'Clean up the page strDocument = Replace(strDocument, vbCr, " ") strDocument = Replace(strDocument, vbLf, " ") strDocument = Replace(strDocument, vbTab, " ") Do While InStr(strDocument, " ") <> 0 : strDocument = Replace(strDocument, " ", " ") : Loop strDocument = Replace(strDocument, "> <", "><") blnGoodURL = False 'Scan for the pointer word. If DEBUG_MESSAGES Then Status "Searching for start: " & strBeginURL If InStr(strDocument, strBeginURL) Then If DEBUG_MESSAGES Then Status "Found start: " & strBeginURL 'Grab the first thing after the pointer word strProcessURL = Mid(strDocument, InStr(strDocument, strBeginURL)) If InStr(strDocument, "http") Then If DEBUG_MESSAGES Then Status "Found ""http""" 'Grab the first thing after the word "http" strProcessURL = Mid(strProcessURL, Instr(strProcessURL, "http")) 'Stop grabbing at the designated end If DEBUG_MESSAGES Then Status "Searching for stop: " & strEndURL If InStr(strProcessURL, strEndURL) <> 0 Then If DEBUG_MESSAGES Then Status "Found stop: " & strEndURL strProcessURL = Left(strProcessURL, InStr(strProcessURL, strEndURL) - 1) blnGoodURL = True End If 'Unescape the URL strProcessURL = Unescape(strProcessURL) strProcessURL = Replace(strProcessURL, "\/", "/") End If End If If blnGoodURL Then If DEBUG_MESSAGES Then Status "URL: " & strProcessURL End If 'Return a URL or an empty string. If blnGoodURL Then ProcessURL = strProcessURL Else ProcessURL = "" End If End Function Function UrlDecode(strText) 'As String Dim strBuffer 'As String Dim lngPosition 'As Long For lngPosition = 1 To Len(strText) If Mid(strText, lngPosition, 1) = "%" Then strBuffer = strBuffer & Chr("&H" & Mid(strText, lngPosition + 1, 2)) lngPosition = lngPosition + 2 Else strBuffer = strBuffer & Mid(strText, lngPosition, 1) End If Next UrlDecode = strBuffer End Function Function GetClipboard() Dim ie Set ie = CreateObject("InternetExplorer.Application") ie.Navigate("about:blank") GetClipboard = ie.Document.ParentWindow.ClipboardData.GetData("text") ie.Quit End Function Function GetData(strUrl) Dim web Const WinHttpRequestOption_EnableRedirects = 6 Set web = Nothing On Error Resume Next 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("Msxml2.XMLHTTP") If web Is Nothing Then Set web = CreateObject("Microsoft.XMLHTTP") web.Option(WinHttpRequestOption_EnableRedirects) = True web.Open "GET", strURL, False web.SetRequestHeader "REFERER", strUrl web.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" web.SetRequestHeader "Accept", "text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5" web.SetRequestHeader "Accept-Language", "en-us,en;q=0.5" web.SetRequestHeader "Accept-Charset", "ISO-8859-1,utf-8;q=0.7,*;q=0.7" web.Send 'Sometimes self-referring can cause problems. If so, try it without the referral. If Left(web.Status, 2) = "40" Then web.SetRequestHeader "REFERER", Null web.send End If If web.Status = "200" Then GetData = web.ResponseText Else GetData = "" End If End Function Function GetRedirect(strUrl) Dim web, strLocation On Error Resume Next 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("Msxml2.XMLHTTP") If web Is Nothing Then Set web = CreateObject("Microsoft.XMLHTTP") web.Open "HEAD", strUrl, False web.SetRequestHeader "REFERER", strUrl web.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" web.SetRequestHeader "Accept", "text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5" web.SetRequestHeader "Accept-Language", "en-us,en;q=0.5" web.SetRequestHeader "Accept-Charset", "ISO-8859-1,utf-8;q=0.7,*;q=0.7" web.Send 'Sometimes self-referring can cause problems. If so, try it without the referral. If Left(web.Status, 2) = "40" Then web.SetRequestHeader "REFERER", Null web.send End If strLocation = "" On Error Resume Next strLocation = web.getResponseHeader("Location") On Error Goto 0 GetRedirect = strLocation End Function Function ContentType(strUrl) Const adTypeBinary = 1 Const adSaveCreateOverWrite = 2 Const ForWriting = 2 Dim web, strContentType If strUrl = "" Then ContentType = "" Else On Error Resume Next 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("Msxml2.XMLHTTP") If web Is Nothing Then Set web = CreateObject("Microsoft.XMLHTTP") If web Is Nothing Then ContentType = "" Exit Function End If web.Open "HEAD", strURL, False web.SetRequestHeader "REFERER", strUrl web.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" web.SetRequestHeader "Accept", "text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5" web.SetRequestHeader "Accept-Language", "en-us,en;q=0.5" web.SetRequestHeader "Accept-Charset", "ISO-8859-1,utf-8;q=0.7,*;q=0.7" web.Send 'Sometimes self-referring can cause problems. If so, try it without the referral. If Left(web.Status, 2) = "40" Then web.SetRequestHeader "REFERER", Null web.send End If strContentType = "" On Error Resume Next strContentType = web.GetResponseHeader("Content-Type") On Error Goto 0 ContentType = strContentType End If End Function Function SaveWebBinary(strUrl, strFile, strCookie) Const adTypeBinary = 1 Const adSaveCreateOverWrite = 2 Const ForWriting = 2 Const WinHttpRequestOption_EnableRedirects = 6 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("Msxml2.XMLHTTP") If web Is Nothing Then Set web = CreateObject("Microsoft.XMLHTTP") On Error Goto 0 If web Is Nothing Then If DEBUG_MESSAGES Then MsgBox "Unable to create WinHTTP object" SaveWebBinary = False Exit Function End If 'web.Option(WinHttpRequestOption_EnableRedirects) = True web.Open "GET", strURL, False web.SetRequestHeader "REFERER", strUrl web.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)" web.SetRequestHeader "Accept", "text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5" web.SetRequestHeader "Accept-Language", "en-us,en;q=0.5" web.SetRequestHeader "Accept-Charset", "ISO-8859-1,utf-8;q=0.7,*;q=0.7" If strCookie <> "" Then web.setRequestHeader "Cookie", strCookie web.Send 'Sometimes self-referring can cause problems. If so, try it without the referral. If Left(web.Status, 2) = "40" Then On Error Resume Next web.SetRequestHeader "REFERER", Null web.send On Error Goto 0 End If If web.Status <> "200" Then If DEBUG_MESSAGES Then MsgBox "Server returned status " & web.Status 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 ts = fs.OpenTextFile(strFile, ForWriting, True) strData = "" strBuffer = "" If UBound(varByteArray) < 2 Then If DEBUG_MESSAGES Then MsgBox "Server returned empty response" ts.Close If fs.FileExists(strFile) Then fs.DeleteFile strFile, True SaveWebBinary = False Exit Function End If 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 Sub Status(strMessage) ' If DEBUG_MESSAGES Then ' WriteLog "____________________" & vbCrLf & Now() & vbCrLf & strMessage & vbCrLf & vbCrLf ' End If If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then Wscript.Echo strMessage End If End Sub Sub ShowHelp() WScript.Echo vbCrLf & "You need to do two things:" & vbCrLf _ & " 1 - Copy a URL whose content you want to save" & vbCrLf _ & " (IE: right-click ""Copy"" or ""Copy Shortcut"")" & vbCrLf _ & " (FireFox: ""Copy Image Location"" or ""Copy Link Location"")" & vbCrLf _ & " For a video file, you may be able to copy the page URL." & vbCrLf _ & " 2 - Pass a destination folder name as an argument by either:" & vbCrLf _ & " * quoted arguments on the command line" & vbCrLf _ & " * dropping a folder on this script" & vbCrLf _ & " * right-clicking a folder and selecting """ & RIGHT_CLICK_TEXT & """" & vbCrLf _ & "If you run this script with no copied URL or no destination folder argument, " & vbCrLf _ & "it will toggle (alternately enable and disable) the right-click option." & vbCrLf & vbCrLf _ & "Current right-click status is " & RightClickStatus() & "." End Sub Function XmlConfig() 'If the local XML file is messed up, try retrieving one from the web. Dim strXml strXml = "" On Error Resume Next strXml = GetData("http://ericphelps.com/scripting/samples/ClipboardDownload/ClipboardDownload.xml") On Error Goto 0 XmlConfig = strXml End Function Sub ToggleRightClick() Dim ws Set ws = CreateObject("Wscript.Shell") If RightClickEnabled() Then ws.RegDelete "HKEY_CLASSES_ROOT\Directory\shell\" & RIGHT_CLICK_TEXT & "\command\" ws.RegDelete "HKEY_CLASSES_ROOT\Directory\shell\" & RIGHT_CLICK_TEXT & "\" Else ws.RegWrite "HKEY_CLASSES_ROOT\Directory\shell\" & RIGHT_CLICK_TEXT & "\command\", "wscript.exe """ & WScript.ScriptFullName & """ %1", "REG_EXPAND_SZ" End If End Sub Function RightClickStatus() If RightClickEnabled() Then RightClickStatus = "ENABLED" Else RightClickStatus = "DISABLED" End If End Function Function RightClickEnabled() Dim ws, strValue Set ws = CreateObject("Wscript.Shell") strValue = "" On Error Resume Next strValue = ws.RegRead("HKEY_CLASSES_ROOT\Directory\shell\" & RIGHT_CLICK_TEXT & "\command\") On Error Goto 0 RightClickEnabled = Eval("" <> strValue) End Function