'Downloads several online hosts files and merges them 
'into your computer's hosts file. 

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

'Define globals
Const WindowsFolder = 0
Const SystemFolder = 1
Const TemporaryFolder = 2
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 'File System Object

Set fs = CreateObject("Scripting.FileSystemObject")

'Set default location of URLs (can be edited by the user in the "database")
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" _
& " http://hostsfile.org/Downloads/hosts.txt"

'Make sure the system has the basics
If Not HasScripting() Then WScript.Quit

'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, Vista
Else	
	gstrHostsFile = fs.BuildPath(fs.GetSpecialFolder(WindowsFolder), "hosts")'Win98
End If

'Assign the "db" database folder location to the same place as the script
gstrDbFolder = fs.BuildPath(fs.GetParentFolderName(Wscript.ScriptFullName), "db")

'Prompt for admin rights if needed
If NeedsUAC() Then 
	If MsgBox("This script needs administrative priveleges to disable " _
	& "your ""DNS Client"" service and update your ""hosts"" file. " _
	& "This script will need to access the Internet, " _
	& "change registry settings, run other programs, and modify files. " _
	& "If your PC security warns you about these actions, you should allow " _
	& "them.", vbOkCancel , "Administrative Rights") <> vbOk Then
		WScript.Quit
	End If
	UAC
End If

'All the prerequisites are handled. Now we can run the program!
Main


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

	Set fs = CreateObject("Scripting.FileSystemObject")
	
	'Make sure the DNS Cache service is stopped
	If Not StopDNS() Then Exit Sub
	
	'Create the database folder and all default files
	If Not fs.FolderExists(gstrDbFolder) Then
		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

	'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 & "# """ & Wscript.ScriptFullName & """" & 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
	If fs.FileExists(FileNameInTempDir("hosts")) Then fs.DeleteFile FileNameInTempDir("hosts")
End Sub

Function StopDNS()
'Returns True if DNS Cache service is (or after it has been) stopped.
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")
	'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." 
				StopDNS = 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"
					StopDNS = False
					Exit Function
				End If
			End If
		Else
			MsgBox "No changes were made. You may re-run this script again later."
			StopDNS = False
			Exit Function
		End If
	End If
	StopDNS = 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.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.WriteLine "www.netflix.com"
		ts.WriteLine "netflix.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 """ & Wscript.ScriptFullName & """ 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
	If Not (rs.BOF And rs.EOF) Then
		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
	End If
	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
	If rs.BOF And rs.EOF Then
		BlackHole = "127.0.0.1"
	Else
		rs.MoveFirst
		'Read the data
		BlackHole = rs.Fields("Address").Value
	End If
	'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
	If rs.BOF And rs.EOF Then
		strUrls = ""
	Else
		rs.MoveFirst
		strUrls = ""
		Do Until rs.EOF
			If strUrls <> "" Then
				strUrls = strUrls & " "
			End If
			strUrls = strUrls & rs.Fields("URL").Value
			rs.MoveNext
		Loop
	End If
	'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

Sub Force32Bit()
'If OS is 64 bit and the script engine is also 64 bit, re-run the script with a 32-bit engine
Dim ws, fs, wmi, col, obj, strBits, strCmd, intArg
	'Use WMI to see whether OS is 32 or 64 bit
	strBits = "32"
	On Error Resume Next
	Set wmi = GetObject("winmgmts:\\.\root\CIMV2")
	Set col = wmi.ExecQuery("SELECT * FROM Win32_OperatingSystem", "WQL", 48)
	For Each obj In col
		strBits = obj.OSArchitecture
	Next
	Set col = Nothing
	Set wmi = Nothing
	On Error Goto 0
	'Test to see if we're on a 64-bit OS and running a 64-bit script engine
	If InStr(strBits, "64") <> 0 Then
		If Instr(WScript.FullName, "SysWOW64") = 0 Then
			'Start building the necessary command line to re-launch the script
			Set ws = CreateObject("Wscript.Shell")
			Set fs = CreateObject("Scripting.FileSystemObject")
			strCmd = fs.BuildPath(fs.GetSpecialFolder(0), "SysWOW64\" & fs.GetFileName(WScript.FullName))
			'Add quotes in case engine has spaces in the path
			If Left(strCmd, 1) <> """" Then
				strCmd = """" & strCmd & """"
			End If
			'Add the script name (with quotes just in case)
			strCmd = strCmd & " """ & WScript.ScriptFullName & """"
			'Add arguments if there are any
			If WScript.Arguments.Count > 0 Then
				For intArg = 0 To WScript.Arguments.Count - 1
					'If there is a space in an argument, add quotes around the argument
					If InStr(WScript.Arguments(intArg), " ") <> 0 Then
						strCmd = strCmd & " """ & WScript.Arguments(intArg) & """"
					Else
						strCmd = strCmd & " " & WScript.Arguments(intArg)
					End If
				Next
			End If
			'Run the script again with the 32-bit engine. Kill this 64-bit script.
			ws.Run strCmd, 1, False
			WScript.Quit
		End If
	End If
End Sub


'**************************************************
'****** Unused routines not worth the bother ******
'**************************************************

'Function DisableAddressBarSearching()
'Dim ws
'	Set ws = CreateObject("WScript.Shell")
' 	'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
'				DisableAddressBarSearching = False
' 				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
'				DisableAddressBarSearching = True
' 				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
'			DisableAddressBarSearching = False
' 			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
' 	End If
'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
' 	'Merging a REG file via a batch file fires fewer security alerts than doing it with scripting.
' 	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

' Function HasWMI()
' 'Returns True is able to get CIMV2
' Dim oTest
' 	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 ("You don't seem to have WMI (Windows Management Infrastructure). May I take you to a Microsoft web page where you can download WMI?", vbYesNo, "WMI") = vbYes Then
' 				ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyID=afe41f46-e213-4cbf-9c5b-fbf236e0e875&DisplayLang=en", 1, False
' 			End If
' 		End If
' 		HasWMI = False
' 	Else
' 		Set oTest = Nothing
' 		HasWMI = True
' 	End If
' End Function



'*********************************************************
'**** UAC (User Access Control) code below this point ****
'*********************************************************

Function NeedsUAC()
'Returns False if UAC not needed (Win9x or Win2K/XP with logged on admin)
'Returns True if UAC needed (Win2K/XP with no admin or every instance of Vista)
	If IsAdmin(UserName()) Then
		If OsVersion() < 6 Then
			NeedsUAC = False
		Else
			NeedsUAC = True
		End If
	Else
		NeedsUAC = True
	End If
End Function

Sub UAC()
'Run this subroutine FIRST THING on any script that may require admin
'priveleges. It will generate a "User Access Control" prompt on Vista
'or generate a "Run As" prompt for admin priveleges on 2K/XP (if the 
'2K/XP user isn't an admin). It will do nothing on Win9x systems or 
'on Win2K/XP systems with a logged-in admin.
Const FOR_WRITING = 2
Const TEMP_FOLDER = 2
Dim ws, fs, ts, wmi, col, obj
Dim strData, strUacFile, strArg, strArgs, strOsVersion, strUserName, strGroup, strMember
Dim lngArg, lngOsVersion
Dim blnIsAdmin, blnHasAdmins
	'See if we can create needed objects
	On Error Resume Next
	Err.Clear
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("WScript.Shell")
	Set wmi = GetObject("winmgmts:\\.\root\CIMV2")
	If Err.Number <> 0 Then Exit Sub 'Reasonable assumption it's Win9x?
	On Error Goto 0
	'Define the name of the special script that will re-launch this one for UAC if needed.
	'Can't use %TEMP% or other per-user folder, can't use script folder because it might be
	'in protected area. 
	strUacFile = ""
	If strUacFile = "" Then
		'First try to use "shared docs" because everyone can get to it.
		strUacFile = ws.RegRead("HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Common Documents")
		If strUacFile <> "" Then
			If fs.FolderExists(strUacFile) Then 
				strUacFile = fs.BuildPath(strUacFile, "~" & fs.GetBaseName(WScript.ScriptName) & ".vbs")
			Else
				strUacFile = ""
			End If
		End If
	End If
	If strUacFile = "" Then
		'Next choice is all users desktop.
		strUacFile = ws.SpecialFolders("AllUsersDesktop")
		If strUacFile <> "" Then
			If fs.FolderExists(strUacFile) Then 
				strUacFile = fs.BuildPath(strUacFile, "~" & fs.GetBaseName(WScript.ScriptName) & ".vbs")
			Else
				strUacFile = ""
			End If
		End If
	End If
	If strUacFile = "" Then
		'Last choice is the drive root. At least we know it exists!
		strUacFile = fs.BuildPath(fs.GetDriveName(WScript.Path) & "\", "~" & WScript.ScriptName)
	End If
	'If the UAC script exists, we can assume it launched this one! It should be deleted.
	If fs.FileExists(strUacFile) Then
		fs.DeleteFile strUacFile
		Exit Sub
	End If	
	'Find the Operating System major version
	Set col = wmi.ExecQuery("SELECT * FROM Win32_OperatingSystem", "WQL", 48)
	strOsVersion = "0.0"
	For Each obj In col : strOsVersion = obj.Version : Next
	If Instr(strOsVersion, ".") Then strOsVersion = Left(strOsVersion, Instr(strOsVersion, ".") - 1)
	lngOsVersion = CLng(strOsVersion)
	'If the OS is less than W2K, everybody is an admin and no UAC prompt is needed
	If lngOsVersion < 5 Then Exit Sub
	'Find the user name (needed to see if the user is an admin)
	Set col = wmi.ExecQuery("SELECT * FROM Win32_ComputerSystem", "WQL", 48)
	strUserName = ""
	For Each obj In col : strUserName = obj.UserName : Next
	If Instr(strUserName, "\") Then	strUserName = Mid(strUserName, Instr(strUserName, "\") + 1)
	'See if the user is an admin
	blnIsAdmin = False
	blnHasAdmins = False
	Set col = wmi.ExecQuery("SELECT * FROM Win32_GroupUser", "WQL", 48)
	For Each obj In col
		strGroup = obj.GroupComponent
		strGroup = Split(strGroup, "=")
		If strGroup(UBound(strGroup)) = """Administrators""" Then
			blnHasAdmins = True
			strMember = obj.PartComponent
			strMember = Split(strMember, "=")
			If strMember(UBound(strMember)) = """" & strUserName & """" Then
				blnIsAdmin = True
			End If
		End If
	Next
	If blnHasAdmins = False Then blnIsAdmin = True 'If no admin group then everybody is an admin?
	'Final test. No UAC prompt is needed if user is admin on something less than Vista
	If ((lngOsVersion < 6) And (blnIsAdmin)) Then Exit Sub
	'This is definitely a directly-run script. We need to re-launch it to get a UAC.
	'First collect any arguments the script has so we can re-launch it exactly the same.
	For lngArg = 0 To WScript.Arguments.Count - 1
		If strArgs <> "" Then strArgs = strArgs & " "
		strArg = WScript.Arguments(lngArg)
		If ((InStr(strArg, " ") <> 0) Or (InStr(strArg, vbTab) <> 0)) Then 
			strArg = """" & """" & strArg & """" & """"
		End If
		strArgs = strArgs & strArg
	Next
	'Now build the actual command that will re-launch the script with a UAC prompt
	strData = "CreateObject(""Shell.Application"").ShellExecute "
	strData = strData & """" & """" & """" & Wscript.FullName & """" & """" & """"
	strData = strData & ", "
	strData = strData & """" & """" & """" & WScript.ScriptFullName & """" & """"
	If strArgs = "" Then
		strData = strData & """, "
	Else
		strData = strData & " " & strArgs & """, "
	End If
	strData = strData & """" & """" & """" & fs.GetParentFolderName(WScript.ScriptFullName) & """" & """" & """"
	strData = strData & ", "
	strData = strData & """runas"""
	strData = strData & ", 1"
	'Save the UAC command in a separate script
	Set ts = fs.OpenTextFile(strUacFile, FOR_WRITING, True)
	ts.Write strData
	ts.Close
	'Show a message
	Wscript.Echo "This script will need administrative priveleges."
	'Launch the UAC script
	ws.Run "wscript.exe" & " """ & strUacFile & """", 1, False
	'We MUST exit at this point and let the UAC script re-launch us.
	WScript.Quit
End Sub

Function HasScripting()
'Returns True if able to create common scripting objects (some WinXP can fail!)
Dim fs, ws, sa, lngErrNum
	Err.Clear
	lngErrNum = 0
	Set ws = CreateObject("WScript.Shell")
	lngErrNum = lngErrNum + Err.Number
	Set fs = CreateObject("Scripting.FileSystemObject")
	lngErrNum = lngErrNum + Err.Number
	Set sa = CreateObject("Shell.Application")
	lngErrNum = lngErrNum + Err.Number
	If lngErrNum <> 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
			ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyId=C717D943-7E4B-4622-86EB-95A22B832CAA&displaylang=en", 1, False
		End If
		HasScripting = False
	Else
		HasScripting = True
	End If
End Function

Function OsVersion()
'Returns the base + minor version for the OS. Returns 0 on error.
'3.5=NT, 4.0=95, 4.1=98, 4.9=ME, 5.0=2K, 5.1=XP, 5.2=2003, 6.0=Vista
Dim strVersion, objWMI, colSystems, objOS
Dim ver, strVer, strVerMajor, strVerMinor, strMajor
	strVersion = "0" 'Set a default of zero in case of error
	On Error Resume Next
	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
	Set objWMI = Nothing
	If InStr(strVersion, ".") > 0 Then
		strVersion = Left(strVersion, InStr(strVersion, ".") + 1)
	End If
	'If WMI fails, try parsing output from the old "ver" command
	If strVersion = "0" Then
		Set ws = CreateObject("Wscript.Shell")
		Set ver = ws.Exec("%comspec% /c ver")
		Do While ver.Status = 0
			WScript.Sleep 100
		Loop
		strVer = ver.StdOut.ReadAll
		strVer = Split(strVer, ".")
		'Get major version
		strMajor = strVer(0)
		strMajor = Split(strMajor, " ")
		strVerMajor = strMajor(UBound(strMajor))
		'Get minor version
		strVerMinor = strVer(1)
		strVerMinor = Left(strVerMinor, 1)
		'Check results
		If IsNumeric(strVerMajor) And IsNumeric(strVerMinor) Then
			strVersion = strVerMajor & "." & strVerMinor
		End If
	End If
	OsVersion = strVersion
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 IsAdmin(strUserName)
	Dim objWMI, colUsers, objUser, strGroup, strUser, 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