'// *********************************************************************** '// General '// '// Name : vbsSimplevURL '// Version : 1.0 '// Author : Ur I.T. Mate Group '// Website : http://www.it-mate.co.uk '// Support : http://support.it-mate.co.uk '// Licence : Freeware '// Release Date : 01-06-2006 '// Revised : N/A '// '// Notes '// '// None '// '// Technical Information '// '// Format : VBScript '// Open Source : No '// Distribution : Permitted '// Platforms : Windows 98, 98SE, ME, NT, 2000, XP Home, XP Pro, Server 2003 '// Requirements : Windows Script 5.6 '// '// Windows Script 5.6 Download locations '// '// 9x/ME/NT : http://surl.co.uk/?354 '// 2000/XP : http://surl.co.uk/?353 '// '// Distribution Information '// '// This file may be distributed freely aslong as this file remains unchanged. You may NOT modify, '// mis-use or otherwise attempt to pass this file off as being written by you!. This file, including '// copyrights, contents, remains the sole property of Ur I.T. Mate Group '// '// *********************************************************************** '// Ensure used vars are declared Option Explicit '// Vars Dim sTemp, sSource '// Timeout - used by URLContent function Const iTimeOutinSecs = 240 '// FileSystemObject - File consts Const vbs_FSORead = 1 Const vbs_FSOWrite = 2 Const vbs_FSOAppend = 8 '// Save ourself some time if the object we need isn't available If NOT IsObject(CreateObject("Scripting.FileSystemObject")) Then WScript.Echo "I'm sorry, The Microsoft Scripting Runtime does not appear to be available on this computer": WScript.Quit If NOT IsObject(CreateObject("MSXML2.ServerXMLHTTP")) Then WScript.Echo "I'm sorry, the MSXML2 object is not available on this computer.": WScript.Quit '// Get URL to request sTemp = InputBox("Please enter the URL of the page you wish to save" & vbCrLf & vbCrLf & "Example: http://www.microsoft.com" & vbCrLf & vbCrLf & "IMPORTANT: Binary target URL's (.exe,.zip,.rar etc) will be ignored","Enter a URL", "http://") '// If value is less than 11, it's an invalid URL If Len(sTemp) < 11 Then WScript.Echo "You entered an invalid URL ... so I'm going to bed ... nite nite": WScript.Quit '// Check Request protocol (only permit HTTP) Select Case LCase(Left(sTemp, 7)) Case "http://": sSource = URLContent(sTemp) Case Else: Wscript.Echo "I'm sorry, if you want to use this script for anything other than HTTP requests," & vbcrlf & "you'll have to add the necessary functionality yourself." & vbCrLf & vbCrLf & "My master couldn't be bothered to add it himself": Wscript.Quit End Select '// If it's an HTML page, add the BASE HREF tag to it If Instr(1, LCase(sSource), "" & vbcrlf & sSource, sTemp Else SaveSource vbs_FSOWrite, sSource, sTemp End If WScript.Echo "Your file has been saved": WScript.Quit Function SaveSource(lMethod, sData, sFilename) '// Declarations Dim objFSO, objFile, sFile '// Prepare the filename that will be used sFile = ".\" & Cleanup(sFilename) & ".html" '// Create the object Set objFSO = CreateObject("Scripting.FileSystemObject") '// If the file exists, use it, otherwise, create it If objFSO.FileExists(sFile) <> True Then Set objFile = objFSO.CreateTextFile(sFile, True) Else Set objFile = objFSO.OpenTextFile(sFile, lMethod, True) End If objFile.Write sData Set objFile = Nothing: Set objFSO = Nothing End Function Function Cleanup(sWhat) Cleanup = Replace(Replace(Replace(Replace(Replace(sWhat, ":", ""), "/", ""), "\", ""), "@", ""), "%", "") End Function Function UrlContent(sURL) '// Declare used vars Dim objXMLHTTP, tmStart, bErrorReturned,tmCurr,iTimeTaken, sURLCTemp '// Create the object we are going to use set objXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP") '// Set request params objXMLHTTP.open "GET", sURL, False '// Set request header (allows site op to identify our script - not necessary, just a courtesy) objXMLHTTP.setRequestHeader "User-Agent", "Ur I.T. Mate Group vURL - http://mysteryfcm.co.uk/?mode=vURL&url=" & sURL '// Send request objXMLHTTP.send "" '// Set timer tmStart = Now '// Set error value to null bErrorReturned = 0 '// Allow checking of ReadyState Do tmCurr = Now iTimeTaken = CInt(DateDiff("s", tmStart, tmCurr)) '// If timeout value reached, or connect state is false, show error and quit If iTimeTaken > iTimeOutInSecs Then WScript.Echo "Error: Query timed out": WScript.Quit objXMLHTTP.abort bErrorReturned = 1 Exit Do End If Loop While objXMLHTTP.readyState <> 4 '// If no error occured, process the data If bErrorReturned <> 1 Then '// If error occured or website status is not 200, display error and quit If err.number <> 0 or objXMLHTTP.status <> 200 then WScript.Echo "Error: " & objXMLHTTP.StatusText: WScript.Quit Else '// If no error occured, get the site's source .... sURLCTemp = objXMLHTTP.ResponseText '// If source length is less than 1, it is null - so show error and quit If Len(Trim(sURLCTemp)) < 1 then WScript.Echo "Error VWD009: Unable to display content": WScript.Quit '// If source length is greater than 1, return it If Len(Trim(sURLCTemp)) > 1 then URLContent = sURLCTemp End If end if set objXMLHTTP = nothing End Function