'Demonstration of UAC (User Access Control) administrative
'prompting needed by Windows Vista. This is also handy in W2K 
'and XP if the user isn't an administrator. 

Option Explicit

'Make sure scripting isn't crippled
If Not HasScripting() Then Wscript.Quit
'Launch a UAC or RUNAS prompt as needed
If NeedsUAC() Then UAC



'INSERT CODE HERE THAT REQUIRES ADMIN PRIVELEGES




'***********************************************************
'****   Below here are the UAC functions and subs!   *******
'***********************************************************

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()
'Re-launches this script with admin priveleges. The original 
'instance of the script is terminated by this subroutine. 
'How it happens - A temporary script is generated that uses 
'the Shell.Application "ShellExecute" method with "runas" 
'to re-launch this script.
Const FOR_WRITING = 2
Dim ws, fs, ts
Dim strData, strUacFile, strArgs, strArg
Dim lngArg
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set ws = CreateObject("Wscript.Shell")
	'Define the name of the special script that will re-launch this one for UAC if needed.
	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
		'Last choice is the drive root. At least we know it exists!
		strUacFile = fs.BuildPath(fs.GetDriveName(WScript.Path) & "\", "~" & fs.GetBaseName(WScript.ScriptName) & ".vbs")
	End If
	'If the UAC script exists, we can assume it launched this one! 
	If fs.FileExists(strUacFile) Then
		'If we were already started by the temporary UAC script, that script should be deleted.
		fs.DeleteFile strUacFile
	Else	
		'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 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
		'There is an awful lot of double-double quoting happening here!
		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 to warn the user why they are about to see a UAC prompt
		Wscript.Echo "This script will need administrative priveleges."
		'Launch the UAC script
		CreateObject("Wscript.Shell").Run "wscript.exe" & " """ & strUacFile & """", 1, False
		'We MUST exit at this point and let the UAC script re-launch us.
		WScript.Quit
	End If
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 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

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