'Downloads several online hosts files and merges them 
'into your computer's hosts file. You must have admin
'priveleges to run this script. 

'Released to Public Domain by Eric Phelps, 2007. May 
'be modified and redistributed with no restrictions.

Option Explicit

'Define globals
Const WindowsFolder = 0
Const SystemFolder = 1
Const TemporaryFolder = 2
Dim gstrMe 'The name of the batch file or script file that runs things
Dim gstrHostsUrls 'The default list of URLs where you can find plain-text hosts files
Dim gstrDbFolder 'The location of the database folder
Dim gstrHostsFile 'The location of the computer's "hosts" file
Dim fs 'Windows File System Object used everywhere


'Create the File System Object
Set fs = CreateObject("Scripting.FileSystemObject")


'Special case for Windows Vista (actually anything newer than Win98) to prompt for UAC priveleges
If OsVersion() > 4 Then
	'Don't launch another instance if this is the second instance!
	If Wscript.Arguments.Count = 0 Then
		'Refuse to run from the temporary folder
		If fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder), Wscript.ScriptName) = Wscript.ScriptFullName Then
			MsgBox "This script is not intended to be run from the temporary folder."
			Wscript.Quit
		End If
		'Show something on a CSCRIPT screen (if there is one) to explain the UAC prompt.
		Status "*************  PROMPTING FOR ADMIN PRIVELEGES  *************"
		Status "This script will back up your hosts file and merge it with"
		Status "data from several online sources. To do this, the script"
		Status "will require administrator priveleges to access the Internet,"
		Status "write files, modify the registry and stop the ""DNS Client"" Service."
		'Copy the script to the %TEMP% folder
		fs.CopyFile Wscript.ScriptFullName, fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder), wscript.ScriptName), True
		'Now fire off a UAC prompt to run the script in the temp folder with elevated priveleges
		CreateObject("Shell.Application").ShellExecute "cscript.exe", """" & fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder), wscript.ScriptName) & """ """ & Wscript.ScriptFullName & """", "", "runas"
		Wscript.Quit
	End If
End If


'Find what file runs things (a batch file or script that 
'launches this script should pass it's name as an argument)
If Wscript.Arguments.Count <> 1 Then
	gstrMe = Wscript.ScriptFullName
Else
	If fs.FileExists(Wscript.Arguments(0)) Then
		gstrMe = Wscript.Arguments(0)
	Else
		gstrMe = Wscript.ScriptFullName
	End If
End If

'Set default location of URLs
gstrHostsUrls = "http://www.malware.com.br/cgi/submit?action=list_hosts_win_127001" _
& " http://pgl.yoyo.org/adservers/serverlist.php?showintro=0;hostformat=hosts" _
& " http://someonewhocares.org/hosts/" _
& " http://www.hostsfile.info/classic127.txt" _
& " http://www.mvps.org/winhelp2002/hosts.txt" _
& " http://sysctl.org/cameleon/hosts.win" _
& " http://hostsfile.mine.nu/Hosts" _
& " http://everythingisnt.com/hosts" _
& " http://www.hostsfile.info/online/hpHOSTS.txt"

'Find the location of the computer's hosts file
If fs.FolderExists(fs.BuildPath(fs.GetSpecialFolder(SystemFolder), "drivers\etc")) Then
	gstrHostsFile = fs.BuildPath(fs.GetSpecialFolder(SystemFolder), "drivers\etc\hosts")'WinNT, Win2000, WinXP
Else	
	gstrHostsFile = fs.BuildPath(fs.GetSpecialFolder(WindowsFolder), "hosts")'Win98
End If

'Set the default location of the database
gstrDbFolder = fs.BuildPath(fs.GetParentFolderName(gstrMe), "db")
'gstrDbFolder = fs.BuildPath(fs.GetParentFolderName(Wscript.ScriptFullName), "db")
'gstrDbFolder = fs.BuildPath(fs.GetParentFolderName(gstrHostsFile), "db")

'Run the program!
Main




Sub Main()
Const ForWriting = 2
Const ForAppending = 8
Dim strUrl, strSQL, strText

	'Warn the user if this is the first time
	If Not fs.FolderExists(gstrDbFolder) Then
		If MsgBox("This script will verify you are an administrator and disable " _
		& "your ""DNS Client"" service. If it succeeds, it will back up your ""hosts"" file and merge your " _
		& "existing hosts data with data from 8 other web sites.", vbOkCancel, "One-Time Notice") <> vbOk Then
			WScript.Quit
		End If
		
		If MsgBox("This script will need to access the Internet and may need to " _
		& "change registry settings, run other programs, and modify files. " _
		& "If your PC security warns you about these actions, you should allow " _
		& "them.", vbOkCancel , "One-Time Notice") <> vbOk Then
			WScript.Quit
		End If
		
		'Create the database folder and all default files
		CreateDatabase

		If MsgBox("A database folder has been created here:" & vbCrLf & gstrDbFolder & vbCrLf _
		& "This folder contains plain-text tab-delimited files you can edit " _
		& "to set the source web sites, your desired ""black hole"" address, " _
		& "desired web hosts, and other settings.  If you click OK now, those settings " _
		& "will be used.", vbOkCancel, "One-Time Notice") <> vbOk Then
			WScript.Quit
		End If
		
	End If

	If Not Ready() Then Exit Sub
	'Back up the existing hosts file
	If fs.FileExists(gstrHostsFile) Then
		fs.CopyFile gstrHostsFile, gstrHostsFile & ".bak", True
	End If
	'Get the existing hosts file data
	If fs.FileExists(gstrHostsFile) Then
		Status vbCrLf & "Reading existing data from """ & gstrHostsFile & """..."
		AppendHosts gstrHostsFile, fs.BuildPath(gstrDbFolder, "hosts1.txt"), BlackHole()
	End If
	'Append the user's list of known bad sites from the database
	Status vbCrLf & "Reading entries from """ & fs.BuildPath(gstrDbFolder, "bad.txt") & """..."
	BadHosts fs.BuildPath(gstrDbFolder, "bad.txt") , fs.BuildPath(gstrDbFolder, "hosts1.txt"), BlackHole()
	'Append all available hosts files from the web
	For Each strUrl In Split(Urls())
		Status vbCrLf & "Merging new entries from " & strUrl & " ..."
		String2File GetData(strUrl), FileNameInTempDir("hosts")
		AppendHosts FileNameInTempDir("hosts"), fs.BuildPath(gstrDbFolder, "hosts1.txt"), BlackHole()
	Next
	'Create the "hosts2.txt" file containing unique ordered bad names
	Status vbCrLf & "Sorting and Removing Duplicates..."
	strSQL = "" _
	& "SELECT DISTINCT [Name], [Domain], [Machine] " _
	& "FROM [Hosts1.txt] " _
	& "ORDER BY [Domain], [Machine];"
	RecordsetToFile strSQL, fs.BuildPath(gstrDbFolder, "hosts2.txt"), ForAppending, "Name", vbTab, vbCrLf
	'Create the "hosts3.txt" file which doesn't contain trusted hosts
	Status vbCrLf & "Removing trusted hosts..."
	strSQL = "" _
	& "SELECT H.Name " _
	& "FROM [Hosts2.txt] H " _
	& "LEFT JOIN [Trusted.txt] T On H.Name = T.Name " _
	& "WHERE T.Name Is Null; "
	RecordsetToFile strSQL, fs.BuildPath(gstrDbFolder, "hosts3.txt"), ForAppending, "Name", vbTab, vbCrLf
	'Write the hosts file header
	Status vbCrLf & "Updating the """ & gstrHostsFile & """ file..."
	strText = "" _
	& "# This file was created by (and can be updated by) running:" & vbCrLf & "# """ & gstrMe & """" & vbCrLf _
	& "# Do not edit this file except to add hosts to be blocked." & vbCrLf _
	& "# To prevent hosts from being added to this file, edit:" & vbCrLf & "# """ & fs.BuildPath(gstrDbFolder, "trusted.txt") & """" & vbCrLf _
	& "# To change the ""black hole"" IP address used, edit:" & vbCrLf & "# """ & fs.BuildPath(gstrDbFolder, "blackhole.txt") & """" & vbCrLf _
	& "# To change the URLs used to get hosts updates, edit:" & vbCrLf & "# """ & fs.BuildPath(gstrDbFolder, "url.txt") & """" & vbCrLf _
	& vbCrLf _
	& "# The ""localhost"" line below is REQUIRED." & vbCrLf _
	& BlackHole() & vbTab & "localhost" & vbCrLf
	String2File strText, gstrHostsFile
	'Write the hosts file legitimate hosts
	Status vbCrLf & "Adding legitimate hosts entries to the ""hosts"" file..."
	strText = vbCrLf & "# Lines in this section are aliases for legitimate hosts" _
	& vbCrLf & "# To add legitimate hosts with live addresses, see:" _
	& vbCrLf & "# """ & fs.BuildPath(gstrDbFolder, "good.txt") & """"

	fs.OpenTextFile(gstrHostsFile, ForAppending, True).WriteLine strText
	strSQL = "" _
	& "SELECT Address, Name " _
	& "FROM [good.txt] " _
	& "ORDER BY Name; "
	RecordsetToFile strSQL, gstrHostsFile, ForAppending, "Address Name", vbTab, vbCrLf
	'Write the main part of the hosts file
	Status vbCrLf & "Adding hosts to be blocked to the ""hosts"" file..."
	strText = vbCrLf & vbCrLf & "# Lines in this section are hosts to be blocked." _
	& vbCrLf & "# To add hosts to always block, see:" _
	& vbCrLf & "# """ & fs.BuildPath(gstrDbFolder, "bad.txt") & """"
	fs.OpenTextFile(gstrHostsFile, ForAppending, True).WriteLine strText
	strSQL = "" _
	& "SELECT B.Address, H.Name " _
	& "FROM [blackhole.txt] B, [hosts3.txt] H;"
	RecordsetToFile strSQL, gstrHostsFile, ForAppending, "Address Name", vbTab, vbCrLf
	'Done! Now delete the data in the temporary files
	strText = "Name" & vbTab & "Machine" & vbTab & "Domain" & vbTab & "(Do not edit this file. It is created and edited by the script.)" 
	fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "hosts1.txt"), ForWriting, True).WriteLine strText
	strText = "Name" & vbTab & "(Do not edit this file. It is created and edited by the script.)" 
	fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "hosts2.txt"), ForWriting, True).WriteLine strText
	fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "hosts3.txt"), ForWriting, True).WriteLine strText
	fs.DeleteFile FileNameInTempDir("hosts")
End Sub

Function Ready()
'Returns True if user is an Administrator and DNS Cache service is stopped.
	'Declare variables
	Const WINDOWS_FOLDER = 0
	Const SYSTEM_FOLDER = 1
	Dim fs, ws, sc, oTest
	Dim strData, blnDNS, strMessage, strUser

	On Error Resume Next
	
	'Create objects
	Err.Clear
	Set ws = CreateObject("WScript.Shell")
	Set fs = CreateObject("Scripting.FileSystemObject")
	If Err.Number <> 0 Then
		If MsgBox ("You seem to have a bad or old installation of Microsoft Windows Scripting. I'd like to take you to a Microsoft web page where you can download Scripting Version 5.6. May I launch your default browser to show you the download page?", vbYesNo, "Update Needed") = vbYes Then
			Select Case OsVersion()
				Case 0
					ws.Run "http://msdn.microsoft.com/downloads/list/webdev.asp?frame=true", 1, False
				Case 5
					ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyID=47809025-d896-482e-a0d6-524e7e844d81&DisplayLang=en"
					'ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyID=f00cb8c0-32e9-411d-a896-f2cd5ef21eb4&DisplayLang=en"
					'ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyID=c03d3e49-b40e-4ca1-a0c7-cc135ec4d2be&displaylang=en"
					'ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyId=C717D943-7E4B-4622-86EB-95A22B832CAA&displaylang=en", 1, False
				Case 6
					ws.Run "http://windowsupdate.microsoft.com/"
				Case Else
					ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyId=0A8A18F6-249C-4A72-BFCF-FC6AF26DC390&displaylang=en", 1, False
			End Select
		End If
		MsgBox "After you finish updating Scripting, you can re-run this installation script."
		Ready = False
		Exit Function
	Else
		Status "Windows Scripting seems functional"
	End If
	
	'Test for optional WMI
	Set oTest = Nothing
	On Error Resume Next
	Err.Clear
	Set oTest = GetObject("winmgmts:\\.\root\CIMV2")
	If oTest Is Nothing Then
		If OsVersion() = 4 Then
			If MsgBox ("Although it is NOT actually required, having WMI installed on on this PC would allow finer control over this installation. May I take you to a Microsoft web page where you can download WMI?", vbYesNo, "Optional Update") = vbYes Then
				ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyID=afe41f46-e213-4cbf-9c5b-fbf236e0e875&DisplayLang=en", 1, False
				MsgBox "After you complete the installation of WMI, you can re-run this script."
				blnReady = False
				Exit Function
			End If
		End If
	Else
		Status "WMI seems functional"
		Set oTest = Nothing
	End If
	
	'Verify user is an Admin
	strUser = UserName()
	If strUser <> "" Then
		If Not IsAdmin(strUser) Then
			Status "User is NOT a member of Administrators group"
			MsgBox "You really need to log in as an ""Administrator"" (one of the following user names):" & vbCrLf & EnumerateAdmins, , "Administrator Login"
			Ready = False
			Exit Function
		Else
			Status "User is a member of Administrators group"
		End If
	Else
		Status "Unable to verfify Admin membership. Will assume it's okay."
	End If
	
	'Verify the DNS Cache service is stopped
	blnDNS = False 'True is a bad thing!
	If ServiceState("DNSCache") <> "Stopped" Then blnDNS = True
	If ServiceStartMode("DNSCache") = "Auto" Then blnDNS = True
	If ServiceStartMode("DNSCache") = "" Then blnDNS = True
	If OsVersion() < 5 Then blnDNS = False 'Win9X has no DNSCache service
	If blnDNS Then 
		If MsgBox("NOTE: In order for you to use a large HOSTS file, I'll need to disable the ""DNS Client"" service. If this computer is part of a domain (if you use this PC to log in at work), you should check with your IT department first. Proceed?", vbYesNo, "Disable DNS Client Service") = vbYes Then
			'Stop the DNS Client service
			Status "Stopping DNSCache service"
			StopService "DNSCache"
			WScript.Sleep 2000
			If ServiceState("DNSCache") = "Running" Then 'Assume no news is good news
				MsgBox "Not good! I was unable to stop the ""DNS Client"" service. You (and by extension, I) may not have permission to muck about with the things we are currently mucking about with. No changes were made. Perhaps you should try again later." 
				Ready = False
				Exit Function
			End If
			'Disable the DNS Client service so it won't start automatically next time
			If ServiceStartMode("DNSCache") = "Auto" Then
				Status "Setting DNSCache service to ""disabled"""
				ws.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\Dnscache\Start", 4, "REG_DWORD"
				If ws.RegRead("HKLM\SYSTEM\CurrentControlSet\Services\Dnscache\Start") <> 4 Then
					'If we can't disable the DNS Client via the registry, try using the NET command...
					ws.Run "net.exe config DNSCache start=disabled", 1, False
					'...and cry about the problem regardless of whether NET worked or not
					MsgBox "I was unable to reliably disable the ""DNS Client"" service. It really should be disabled or set to manual. I'm afraid you may need to do this manually!", , "Service Error"
					blnReady = False
					Exit Function
				End If
			End If
		Else
			MsgBox "No changes were made. You may re-run this script again later."
			Ready = False
			Exit Function
		End If
	End If
	
' 	'Talk the user into disabling "Search from the Address bar"
' 	If ws.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Main\AutoSearch") <> 0 Then
' 		If MsgBox("The ""Search from the Address bar"" feature in Internet Explorer can misbehave when used with a restrictive hosts file. This can cause a good web page to be replaced by a search error page. May I disable address bar searching?", vbYesNo, "IE Settings Change") = vbYes Then
' 			ws.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Main\AutoSearch", 0, "REG_DWORD"
' 			If ws.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Main\AutoSearch") <> 0 Then
' 				Status "Unable to disable the ""Search from the Address bar"" feature in IE"
' 				MsgBox "I was unable to turn off address bar searching. If it ends up causing problems in the future, you can turn the address bar search feature on and off yourself from the ""Advanced"" tab of the ""Internet Properties"" control."
' 			Else
' 				Status "Disabled the ""Search from the Address bar"" feature in IE"
' 				If MsgBox("Okay. I did that for you (" & UserName() & "), but turning off address bar searching is something that needs to be done for every user! Assuming there are other users, should I put a script in the ""Startup"" folder that will turn off address bar searching for all the other users?", vbYesNo, "Other Users") = vbYes Then
' 					AddressBarSearchScript ws.SpecialFolders("AllUsersStartup")
' 				End If
' 			End If
' 		Else
' 			MsgBox "No problem. You can turn the address bar search feature on and off yourself from the ""Advanced"" tab of the ""Internet Properties"" control."
' 		End If
' 	Else
' 		Status """Search from the Address bar"" is already disabled."
' 	End If
	Ready = True
End Function

Sub CreateDatabase()
Const ForWriting = 2
Const WindowsFolder = 0
Const SystemFolder = 1
Dim ts, strHostsFile, strURL, strSchema

	'First create the DB folder
	If Not fs.FolderExists(gstrDbFolder) Then
		fs.CreateFolder gstrDbFolder
	End If
	
	'Create DB files
	If Not fs.FileExists(fs.BuildPath(gstrDbFolder, "schema.ini")) Then
		Set ts = fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "schema.ini"), ForWriting, True)
		strSchema =  vbCrLf & "Format=TabDelimited" & vbCrLf & "ColNameHeader=True" & vbCrLf & "MaxScanRows=0" & vbCrLf & "CharacterSet=ANSI" & vbCrLf
		ts.WriteLine "[good.txt]" & strSchema
		ts.WriteLine "[bad.txt]" & strSchema
		ts.WriteLine "[trusted.txt]" & strSchema
		ts.WriteLine "[blackhole.txt]" & strSchema
		ts.WriteLine "[url.txt]" & strSchema
		ts.WriteLine "[hosts1.txt]" & strSchema
		ts.WriteLine "[hosts2.txt]" & strSchema
		ts.WriteLine "[hosts3.txt]" & strSchema
		ts.Close 
	End If
	If Not fs.FileExists(fs.BuildPath(gstrDbFolder, "good.txt")) Then
		Set ts = fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "good.txt"), ForWriting, True)
		ts.WriteLine "Address" & vbTab & "Name" & vbTab & "(Legitimate tab-delimited address/name pairs that will ALWAYS be part of your hosts file.)"
		ts.WriteLine "192.168.0.1" & vbTab & "router"
		ts.WriteLine "127.0.0.1" & vbTab & "pop3.norton.antivirus"
		ts.WriteLine "127.0.0.1" & vbTab & "pop3.spa.norton.antivirus"
		ts.Close 
	End If
	If Not fs.FileExists(fs.BuildPath(gstrDbFolder, "bad.txt")) Then
		Set ts = fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "bad.txt"), ForWriting, True)
		ts.WriteLine "Name" & vbTab & "(Personal list of bad host names that will ALWAYS be added to your hosts file.)"
		ts.WriteLine "btbilgisayarkursu.com"
		ts.WriteLine "dgdg567.com"
		ts.Close 
	End If
	If Not fs.FileExists(fs.BuildPath(gstrDbFolder, "trusted.txt")) Then
		Set ts = fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "trusted.txt"), ForWriting, True)
		ts.WriteLine "Name" & vbTab & "(Personal list of good host names that will NEVER be added to your hosts file.)"
		ts.WriteLine "google.com"
		ts.WriteLine "www.google.com"
		ts.WriteLine "orbitz.com"
		ts.WriteLine "www.orbitz.com"
		ts.WriteLine "travelocity.com"
		ts.WriteLine "www.travelocity.com"
		ts.WriteLine "activex.microsoft.com"
		ts.WriteLine "codecs.microsoft.com"
		ts.WriteLine "msdownload.microsoft.com"
		ts.WriteLine "genuine.microsoft.com"
		ts.WriteLine "windowsupdate.microsoft.com"
		ts.WriteLine "www.update.microsoft.com"
		ts.WriteLine "www.microsoft.com"
		ts.WriteLine "www.msn.com"
		ts.WriteLine "www.yahoo.com"
		ts.WriteLine "wunderground.com"
		ts.Close 
	End If
	If Not fs.FileExists(fs.BuildPath(gstrDbFolder, "blackhole.txt")) Then
		Set ts = fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "blackhole.txt"), ForWriting, True)
		ts.WriteLine "Address" & vbTab & "(Black Hole IP address you want to use in your hosts file.)" 
		ts.WriteLine "127.0.0.1"
		ts.Close 
	End If
	
	'Create a default list of hosts to use
	If Not fs.FileExists(fs.BuildPath(gstrDbFolder, "url.txt")) Then
		Set ts = fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "url.txt"), ForWriting, True)
		ts.WriteLine "URL" & vbTab & "(List of URLs with plain-text hosts files you can use.)" 
		For Each strUrl In Split(gstrHostsUrls)
			ts.WriteLine strUrl
		Next
		ts.Close 
	End If
	
	'Create temporary files new every time because we need them to start out empty. 
	'Create "hosts1.txt" temporary table
	Set ts = fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "hosts1.txt"), ForWriting, True)
	ts.WriteLine "Name" & vbTab & "Machine" & vbTab & "Domain" & vbTab & "(Do not edit this file. It is created and edited by the script.)" 
	ts.Close
	'Create "hosts2.txt" temporary table
 	Set ts = fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "hosts2.txt"), ForWriting, True)
 	ts.WriteLine "Name" & vbTab & "(Do not edit this file. It is created and edited by the script.)" 
 	ts.Close
	'Create "hosts3.txt" temporary table
 	Set ts = fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "hosts3.txt"), ForWriting, True)
 	ts.WriteLine "Name" & vbTab & "(Do not edit this file. It is created and edited by the script.)" 
 	ts.Close
 	
	'Create a "readme" file new every time because it documents the location of this script
 	Set ts = fs.OpenTextFile(fs.BuildPath(gstrDbFolder, "Read_Me.txt"), ForWriting, True)
 	ts.WriteLine "****************** This is a description of the files in this directory ******************"
 	ts.WriteLine "Files are the ""database"" for the """ & gstrMe & """ script."
 	ts.WriteLine "If any file is deleted, it will be regenerated by the script."
 	ts.WriteLine """schema.ini"" - Identifies the data format in each file. Do not modify this file."
 	ts.WriteLine "**** Files described below may be modified as long as the first line is not changed. ****"
	ts.WriteLine ""
 	ts.WriteLine """bad.txt"" - List of bad host names that will ALWAYS be added to your hosts file."
 	ts.WriteLine """blackhole.txt"" - IP address (like 0.0.0.0 or 127.0.0.1) you want to use in your hosts file."
 	ts.WriteLine """good.txt"" - Legitimate tab-delimited address/name pairs that will ALWAYS be part of your hosts file."
 	ts.WriteLine """hosts1.txt"" - Temporary file used while updating."
 	ts.WriteLine """hosts2.txt"" - Temporary file used while updating."
 	ts.WriteLine """hosts3.txt"" - Temporary file used while updating."
 	ts.WriteLine """trusted.txt"" - List of good host names that will NEVER be added to your hosts file."
 	ts.WriteLine """url.txt"" - URLs of plain-text hosts files you want to merge into your hosts file."
	If OsVersion() > 5 Then
		ts.WriteLine vbCrLf
		ts.WriteLine "************************* WINDOWS VISTA EDITING TIP **********************"
		ts.WriteLine "Drag a file out of this protected folder to the desktop. You'll be prompted"
		ts.WriteLine "to confirm the action. Edit and save the file on your desktop. When you are"
		ts.WriteLine "done, drag the file back to this folder. You'll be prompted again to confirm"
		ts.WriteLine "the action."
	End If
 	ts.Close
End Sub

Sub AppendHosts(strSourceFile, strDestFile, strBlackHole)
'Reads a hosts file in and appends tab-delimited machine and domain
'name data to the "hosts1.txt" file.
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Dim tsSource, tsDest
Dim strHostsFile, strLine, strIP, strMachine, strDomain, strHost
Dim varHost, intPart, strTLD, strSLD
	If fs.FileExists(strSourceFile) Then
		'Read the source "hosts" file line-at-a-time, writing to the destination
		Set tsSource = fs.OpenTextFile(strSourceFile, ForReading, False)
		Set tsDest = fs.OpenTextFile(strDestFile, ForAppending, False)
		Do While Not tsSource.AtEndOfStream
			strLine = tsSource.ReadLine
			strLine = Trim(strLine)
			If Len(strLine) > 6 Then
				If ((Left(strLine, 1) <> "#") And (IsNumeric(Left(strLine, 1)))) Then
					Do While InStr(strLine, vbTab ) <> 0
						strLine = Replace(strLine, vbTab, " ")
					Loop
					Do While InStr(strLine, "#" ) <> 0
						strLine = Replace(strLine, "#", " ")
					Loop
					Do While InStr(strLine, "  " ) <> 0
						strLine = Replace(strLine, "  ", " ")
					Loop
					'strIP, strMachine, strDomain, strHost
					strIP = Split(strLine)(0)
					If Ubound(Split(strIP, ".")) = 3 Then
						strHost = Split(strLine)(1)
						Status strHost
						'Verify the IP is blacklisted
						If ((InStr(strIP, "127.") = 1) _
							Or (InStr(strIP, "0.0.0.") = 1) _
							Or (InStr(strIP, strBlackHole) = 1)) Then
							'Separate out the parts of the host name
							varHost = Split(strHost, ".")
							strTLD = ""
							strSLD = ""
							strMachine = ""
							For intPart = UBound(varHost) To 0 Step -1
								If strTLD = "" Then
									strTLD = varHost(intPart)
								Else
									If strSLD = "" Then 
										strSLD = varHost(intPart)
									Else
										If strMachine <> "" Then
											strMachine = "." & strMachine
										End If
										strMachine = varHost(intPart) & strMachine
									End If
								End If
							Next
							'Write the data to the destination
							If ((strSLD <> "") And (strTLD <> "")) Then
								tsDest.WriteLine strHost & vbTab & strMachine & vbTab & strSLD & "." & strTLD
							End If
						End If
					End If
				End If
			End If
		Loop
		tsSource.Close
		tsDest.Close
	End If
End Sub

Sub BadHosts(strSourceFile, strDestFile, strBlackHole)
'Reads the list of hosts in the "bad.txt" file in and appends 
'tab-delimited machine and domain name data to the "hosts1.txt" file.
'Virtually identical to the "AppendHosts" subroutine except that
'this doesn't handle IP addresses.
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Dim tsSource, tsDest
Dim strHostsFile, strLine, strIP, strMachine, strDomain, strHost
Dim varHost, intPart, strTLD, strSLD
	If fs.FileExists(strSourceFile) Then
		'Read the source "hosts" file line-at-a-time, writing to the destination "hosts.txt"
		Set tsSource = fs.OpenTextFile(strSourceFile, ForReading, False)
		Set tsDest = fs.OpenTextFile(strDestFile, ForAppending, False)
		strLine = tsSource.ReadLine 'Read the first line as a throwaway
		Do While Not tsSource.AtEndOfStream
			strLine = tsSource.ReadLine
			strHost = Trim(strLine)
			If Len(strLine) > 6 Then
				Status strHost
				'Separate out the parts of the host name
				varHost = Split(strHost, ".")
				strTLD = ""
				strSLD = ""
				strMachine = ""
				For intPart = UBound(varHost) To 0 Step -1
					If strTLD = "" Then
						strTLD = varHost(intPart)
					Else
						If strSLD = "" Then 
							strSLD = varHost(intPart)
						Else
							If strMachine <> "" Then
								strMachine = "." & strMachine
							End If
							strMachine = varHost(intPart) & strMachine
						End If
					End If
				Next
				'Write the data to the destination
				If ((strSLD <> "") And (strTLD <> "")) Then
					tsDest.WriteLine strHost & vbTab & strMachine & vbTab & strSLD & "." & strTLD
				End If
			End If
		Loop
		tsSource.Close
		tsDest.Close
	End If
End Sub

Sub RecordsetToFile(strSQL, strDestFile, lngFileMode, strOutputFields, strFieldSeparator, strLineSeparator)
'Reads in a recordset and spits out delimited text to a file.
Const ForWriting = 2
Const adLockReadOnly = 1
Const adOpenStatic = 3
Dim cn, rs, ts
Dim strOutputField, blnFirstLine, blnFirstField
	'Create objects
	Set rs = CreateObject("ADODB.Recordset")
	Set cn = CreateObject("ADODB.Connection")
	Set ts = fs.OpenTextFile(strDestFile, lngFileMode, True)
	'Create the database connection
	cn.Provider = "Microsoft.Jet.OLEDB.4.0"
	cn.Properties("Data Source") = gstrDbFolder
	cn.Properties("Extended Properties").Value = "text;"
	cn.Open 
	'Open the recordset
	rs.ActiveConnection = cn
	rs.CursorType = adOpenStatic
	rs.LockType = adLockReadOnly
	rs.Source = strSQL
	rs.Open
	rs.MoveFirst
	blnFirstLine = True
	blnFirstField = True
	Do While Not rs.EOF
		blnFirstField = True
		If Not blnFirstLine Then
			ts.Write strLineSeparator
		Else
			blnFirstLine = False
		End If
		For Each strOutputField In Split(strOutputFields)
			If Not blnFirstField Then
				ts.Write strFieldSeparator
			Else
				blnFirstField = False
			End If
			If Not IsNull(rs.Fields(strOutputField).Value) Then
				ts.Write rs.Fields(strOutputField).Value
			End If
		Next
		rs.MoveNext
	Loop
	ts.Close 
	Set ts = Nothing
	'ADO Cleanup
	rs.Close
	Set rs = Nothing
	cn.Close
	Set cn = Nothing
End Sub

Function String2File(strData, strFileName)
'Writes a string to a file. Returns True if success.
Dim ts 'As Scripting.TextStream
Dim lngChar, strBlock, intChar, dtTimeStamp
Const ForWriting = 2
	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

Function FileNameInTempDir(strFileName) 'As String
'Returns the full path and file name to a file in the user's temporary directory
Const TemporaryFolder = 2
	FileNameInTempDir = fs.GetAbsolutePathName(fs.BuildPath(fs.GetSpecialFolder(TemporaryFolder), strFileName))
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("Microsoft.XMLHTTP")
	If web Is Nothing Then
		GetData = ""
		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"
	web.Send
	If web.Status = "200" Then
		GetData = web.ResponseText
	Else
		GetData = ""
	End If
End Function

Sub Status(strMessage)
	If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then
		Wscript.Echo strMessage
	End If
End Sub

Function BlackHole()
'Returns the IP address listed in the "black hole" table
'LockTypeEnum
Const adLockBatchOptimistic = 4
Const adLockOptimistic = 3
Const adLockPessimistic = 2
Const adLockReadOnly = 1
'CursorTypeEnum
Const adOpenDynamic = 2
Const adOpenForwardOnly = 0
Const adOpenStatic = 3
Dim cn, rs
	'Create the database connection
	Set cn = CreateObject("ADODB.Connection")
	cn.Provider = "Microsoft.Jet.OLEDB.4.0"
	cn.Properties("Data Source") = gstrDbFolder
	cn.Properties("Extended Properties").Value = "text;"
	cn.Open 
	'Open the recordset
	Set rs = CreateObject("ADODB.Recordset")
	rs.ActiveConnection = cn
	rs.CursorType = adOpenStatic
	rs.LockType = adLockReadOnly
	rs.Source = "SELECT * FROM [blackhole.txt]"
	rs.Open
	rs.MoveFirst
	'Read the data
	BlackHole = rs.Fields("Address").Value
	'ADO Cleanup
	rs.Close
	Set rs = Nothing
	cn.Close
	Set cn = Nothing
End Function

Function Urls()
'Returns a space-delimited collection of URLs
'LockTypeEnum
Const adLockBatchOptimistic = 4
Const adLockOptimistic = 3
Const adLockPessimistic = 2
Const adLockReadOnly = 1
'CursorTypeEnum
Const adOpenDynamic = 2
Const adOpenForwardOnly = 0
Const adOpenStatic = 3
Dim cn, rs, strUrls
	'Create the database connection
	Set cn = CreateObject("ADODB.Connection")
	cn.Provider = "Microsoft.Jet.OLEDB.4.0"
	cn.Properties("Data Source") = gstrDbFolder
	cn.Properties("Extended Properties").Value = "text;"
	cn.Open 
	'Open the recordset
	Set rs = CreateObject("ADODB.Recordset")
	rs.ActiveConnection = cn
	rs.CursorType = adOpenStatic
	rs.LockType = adLockReadOnly
	rs.Source = "SELECT * FROM [url.txt]"
	rs.Open
	rs.MoveFirst
	strUrls = ""
	Do Until rs.EOF
		If strUrls <> "" Then
			strUrls = strUrls & " "
		End If
		strUrls = strUrls & rs.Fields("URL").Value
		rs.MoveNext
	Loop
	'ADO Cleanup
	rs.Close
	Set rs = Nothing
	cn.Close
	Set cn = Nothing
	Urls = strUrls
End Function

Sub StopService(strServiceName)
	Dim blnDependencies, objWMI, objService, colServices
	On Error Resume Next
	Err.Clear
	Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
	Set colServices = objWMI.ExecQuery("Associators of {Win32_Service.Name='" & strServiceName & "'} Where AssocClass=Win32_DependentService " & "Role=Antecedent" )
	blnDependencies = False 
	For Each objService in colServices
		blnDependencies = True 
		objService.StopService
	Next
	If blnDependencies = True Then 
		Wscript.Sleep 20000
	End If
	Set colServices = objWMI.ExecQuery("Select * from Win32_Service where Name='" & strServiceName & "'")
	For Each objService in colServices
		objService.StopService()
	Next
	Set objWMI = Nothing
	'If WMI fails, try running NET.EXE to stop service
	If Err.Number <> 0 Then
		CreateObject("WScript.Shell").Run "net.exe stop " & strServiceName, 0, False
	End If
End Sub

Function ServiceState(strServiceName)
	'Returns "Running", "Stopped", "Starting", "Stopping", or ""
	Dim objWMI, colServices, objService, strState, strStartMode
	On Error Resume Next
	Err.Clear
	Set objWMI = GetObject("winmgmts:\\.\root\CIMV2")
	Set colServices = objWMI.ExecQuery("SELECT * FROM Win32_Service WHERE NAME='" & strServiceName & "'", "WQL", 48)
	For Each objService In colServices
		strState = objService.State
	Next
	If Err.Number <> 0 Then
		ServiceState = "" 'Return empty string on WMI failure
	Else
		ServiceState = strState
	End If
	Set objWMI = Nothing
End Function

Function ServiceStartMode(strServiceName)
	'Returns "Auto", "Disabled", "Manual", or ""
	Dim objWMI, colServices, objService, strState, strStartMode
	On Error Resume Next
	Err.Clear
	Set objWMI = GetObject("winmgmts:\\.\root\CIMV2")
	Set colServices = objWMI.ExecQuery("SELECT * FROM Win32_Service WHERE NAME='" & strServiceName & "'", "WQL", 48)
	For Each objService In colServices
		strStartMode = objService.StartMode
	Next
	If Err.Number <> 0 Then
		ServiceStartMode = "" 'Return empty string on WMI failure
	Else
		ServiceStartMode = strStartMode
	End If
	Set objWMI = Nothing
End Function

Function OsVersion()
	'Returns the base number for the OS (4 = Win9x, 5 = 2K/XP, 6 = Vista, 0 = unknown)
	Dim lngVersion, strVersion, objWMI, colSystems, objOS
	On Error Resume Next
	Err.Clear
	Set objWMI = GetObject("winmgmts:\\.\root\CIMV2")
	Set colSystems = objWMI.ExecQuery("SELECT * FROM Win32_OperatingSystem", "WQL", 48)
	For Each objOS In colSystems
		strVersion = objOS.Version
	Next
	If Err.Number <> 0 Then
		strVersion = "4" 'Assume lack of WMI means Windows 9X
	End If
	If InStr(strVersion, ".") > 1 Then
		strVersion = Left(strVersion, InStr(strVersion, ".") - 1)
	End If
	If IsNumeric(strVersion) Then
		lngVersion = Clng(strVersion)
	Else
		lngVersion = 0
	End If
	OsVersion = lngVersion
	Set objWMI = Nothing
End Function

Function IsAdmin(strUserName)
	Dim objWMI, colUsers, objUser, strGroup, blnIsAdmin, blnHasAdmins
	On Error Resume Next
	Err.Clear
	Set objWMI = GetObject("winmgmts:\\.\root\CIMV2")
	Set colUsers = objWMI.ExecQuery("SELECT * FROM Win32_GroupUser", "WQL", 48)
	If Err.Number <> 0 Then
		'Assume WMI failure means Win9X, implying user is an Administrator
		IsAdmin = True
	Else
		blnIsAdmin = False
		blnHasAdmins = False
		For Each objUser In colUsers
			strGroup = objUser.GroupComponent
			strGroup = Split(strGroup, "=")
			If strGroup(UBound(strGroup)) = """Administrators""" Then
				blnHasAdmins = True
				strUser = objUser.PartComponent
				strUser = Split(strUser, "=")
				If strUser(UBound(strUser)) = """" & strUserName & """" Then
					blnIsAdmin = True
				End If
			End If
		Next
	End If
	If blnHasAdmins = False Then
		'If there are no members of the Administrators group, assume everybody is an admin
		IsAdmin = True
	Else
		IsAdmin = blnIsAdmin 
	End If
End Function

Function EnumerateAdmins()
	'Returns space-delimited quoted user names
	Dim objWMI, colUsers, objUser, strGroup, strUser, strUsers, blnIsAdmin
	On Error Resume Next
	Err.Clear
	strUsers = ""
	Set objWMI = GetObject("winmgmts:\\.\root\CIMV2")
	Set colUsers = objWMI.ExecQuery("SELECT * FROM Win32_GroupUser", "WQL", 48)
	If Err.Number = 0 Then
		For Each objUser In colUsers
			strGroup = objUser.GroupComponent
			strGroup = Split(strGroup, "=")
			If strGroup(UBound(strGroup)) = """Administrators""" Then
				strUser = objUser.PartComponent
				strUser = Split(strUser, "=")
				If strUsers <> "" Then strUsers = strUsers & " "
				strUsers = strUsers & strUser(UBound(strUser))
			End If
		Next
	End If
	EnumerateAdmins = strUsers
End Function

Function UserName()
	Dim objWMI, colComputers, objComputer, strUser, ws, env
	On Error Resume Next
	strUser = ""
	Err.Clear
	Set objWMI = GetObject("winmgmts:\\.\root\CIMV2")
	Set colComputers = objWMI.ExecQuery("SELECT * FROM Win32_ComputerSystem", "WQL", 48)
	If Err.Number <> 0 Then
		'WMI Failure. Try environment
		Set ws = CreateObject("Wscript.Shell")
		Set env = ws.Environment("Process")
		strUser = env.Item("USERNAME")
	Else
		For Each objComputer In colComputers
			strUser = objComputer.UserName
		Next
		If Instr(strUser, "\") Then
			strUser = Mid(strUser, Instr(strUser, "\") + 1)
		End If
	End If
	Set objWMI = Nothing
	UserName = strUser
End Function

Function AddressBarSearchScript(strFolder)
	Dim strData
	'Win9x family may not have a valid folder, so bail out with an error
	If strFolder = "" Then 
		AddressBarSearchScript = False
		Exit Function
	End If
	strData = ""
	strData = strData & "::  This file disables the ""Search from the Address bar"" feature " & vbCrLf
	strData = strData & "::  in Internet Explorer. This feature can cause problems when " & vbCrLf
	strData = strData & "::  used with restrictive hosts files. This computer uses such a " & vbCrLf
	strData = strData & "::  hosts file. The person who installed the hosts file elected to " & vbCrLf
	strData = strData & "::  install this file to make sure other users did not experience " & vbCrLf
	strData = strData & "::  problems with Internet Explorer replacing a good web page with " & vbCrLf
	strData = strData & "::  a search web page." & vbCrLf & vbCrLf
	'For some wacky reason, batch files can do anything.
	'Like create a Win98 Registry file (works on 2K/XP) and merge it.
	'If I'd done this with a script, it would fire security alerts.
	'Unfortunately (and appropriately) it fires alerts in Vista.
	strData = strData & "@echo off" & vbCrLf
	strData = strData & " >""%temp%\DisableAddressBarSearch.reg"" echo REGEDIT4" & vbCrLf
	strData = strData & ">>""%temp%\DisableAddressBarSearch.reg"" echo." & vbCrLf
	strData = strData & ">>""%temp%\DisableAddressBarSearch.reg"" echo [HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Main\]" & vbCrLf
	strData = strData & ">>""%temp%\DisableAddressBarSearch.reg"" echo ""AutoSearch""=dword:00000000" & vbCrLf
	strData = strData & ">>""%temp%\DisableAddressBarSearch.reg"" echo." & vbCrLf
	strData = strData & "start /w regedit.exe /s ""%temp%\DisableAddressBarSearch.reg""" & vbCrLf
	strData = strData & "del ""%temp%\DisableAddressBarSearch.reg"" > nul" & vbCrLf
	strData = strData & "cls" & vbCrLf
	strData = strData & "exit"
	AddressBarSearchScript = String2File(strData, CreateObject("Scripting.FileSystemObject").BuildPath(strFolder, "Disable Address Bar Searching.bat")) 
End Function