'-----------------------------------------------------------------------------
' file:		RPCHTP.vbs
'
' THIS CODE AND INFORMATION IS PROVIDED TO YOU FOR YOUR REFERENTIAL PURPOSES 
' ONLY, AND IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EITHER 
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES 
' OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE, AND MAY NOT 
' BE REDISTRIBUTED IN ANY MANNER.
'
' Copyright (C) 2003  Microsoft Corporation.  All rights reserved.
'
'Disclaimer
'
'The sample scripts are not supported under any Microsoft standard support program or service. 
'The sample scripts are provided AS IS without warranty of any kind. Microsoft further disclaims 
'all implied warranties including, without limitation, any implied warranties of merchantability 
'or of fitness for a particular purpose. The entire risk arising out of the use or performance of 
'the sample scripts and documentation remains with you. In no event shall Microsoft, its authors, 
'or anyone else involved in the creation, production, or delivery of the scripts be liable for any 
'damages whatsoever (including, without limitation, damages for loss of business profits, business 
'interruption, loss of business information, or other pecuniary loss) arising out of the use of or 
'inability to use the sample scripts 'or documentation, even if Microsoft has been advised of the 
'possibility of such damages.
'-----------------------------------------------------------------------------
'-----------------------------------------------------------------------------
'History:	RL - 7/1/03: modified for deployment.
'		RL- 7/14/03: modified the servercheck function.
'-----------------------------------------------------------------------------

Option Explicit
On Error Resume Next
'-----------------------------
' Constants
'-----------------------------
Const cLogFile = "RPCHTTP.log"
Const ForAppending = 8
Const TemporaryFolder = 2
Const cTitle = "RPC over HTTP" 
Const Off11FamilyCode = "{????????-6000-11D3-8CFE-0?50048383C9}"

'-----------------------------
' Objects
'-----------------------------
Dim WshShell : Set WshShell = CreateObject("Wscript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim msi : Set msi = CreateObject("WindowsInstaller.Installer")

'-----------------------------
' Path Variables
'-----------------------------
Dim root : root = fso.GetParentFolderName(Wscript.ScriptFullName)
Dim	sUserProfile : sUserProfile = wshShell.ExpandEnvironmentStrings("%USERPROFILE%")
Dim sTemp : sTemp = fso.GetSpecialFolder(TemporaryFolder)
Dim sLogFile : sLogFile = fso.BuildPath(sTemp,cLogFile)
Dim srcPRFFile : srcPRFFile = ""
Dim dstPRFFile : dstPRFFile = ""

Dim sPRFFile : sPRFFile = ""
Dim output : output = ""
Dim sExgSrvr : sExgSrvr = ""
Dim errors : errors = ""
'-----------------------------
' Booleans
'-----------------------------
Dim bNeedsReboot : bNeedsReboot = FALSE
Dim bDebug : bDebug = FALSE
Dim bManual : bManual = FALSE
Dim bOffice11Installed :  bOffice11Installed = FALSE
'-----------------------------
' Operating System Variables
'-----------------------------
Dim osVer,osCSDVer,osBuild,osSPMaj,osSPMin,osLanguage

'-----------------------------
' Exchange Servers-PRF Files
' History: RL - 7/10/03: preparing this file for deployment. 
'	Commented out MS servers, and added "mail.prf" 
'-----------------------------
sPRFFile = "mail.prf"

CreateLog
WriteLog "Root: " & root
WriteLog "Temporary Directory: " & sTemp
WriteLog "UserProfile: " & sUserProfile

'Make sure we can run the script on this machine
bOffice11Installed = IsOffice11Installed()
If Not bOffice11Installed then
	WriteLog "Outlook 2003 is not Installed."
	wshShell.Popup "RPC over HTTP requires Outlook 2003 to be installed.",0,cTitle
	EndScript 1050
End If
DetectOS
If (osVer < "5.1") OR ( (osVer = "5.1") AND (osSPMaj < 1)) Then
	WriteLog "Operating System does not support RPC over HTTP."
	wshShell.Popup "In order to work, RPC over HTTP requires Windows XP SP2.  Go to http://windowsupdate.microsoft.com to install Windows XP SP2.",0,cTitle
	EndScript 1012
End If
If ( (osVer = "5.1") AND (osSPMaj = 1) AND (osLanguage <> 1033) ) Then
	WriteLog "Operating System does not support RPC over HTTP."
	wshShell.Popup "RPC over HTTP requires an English version of Windows XP SP2.  Go to http://windowsupdate.microsoft.com to install Windows XP SP2.",0,cTitle
	EndScript 1012
End If

'After we know that ths script should be able to run, notify the user of the pre-requisites
Dim popret : popret = 0
popret = WshShell.Popup("This script will modify your default MAPI profile.  If your current default profile is not the one you want to enable for RPC/HTTP, exit now and make it your default by using the Mail Applet in the Control Panel.  Would you like to continue?",0,cTitle,4)
If popret = 7 Then
	EndScript 0
End If

'----------------------------------------------------------------
'Main Function
'
'	Complete all the steps necessary to configure the Machine for RPC/HTTP
'
'----------------------------------------------------------------
ServerCheck 'Doing Step3 First.  If PRF File doesnot exist, then should not proceed.
If (sPRFFile <> "") AND fso.FileExists(srcPRFFile) Then
  EnableUI
	EnableBCM
  
	If osVer = "5.1" AND osSPMaj = 1 Then
		InstallQFE
		If Not QFE_IsInstalled("Q331320") Then
			WshShell.Popup "Hotfix has not been installed. RPC over HTTP could not be configured.",0,cTitle
			EndScript 1603
		End If
	End If
	ReplicatePRF
	ImportPRF
	RemoveFirstRun
	FinishDialog
	EndScript 0
Else
	wshshell.Popup "Either you did not save mail.prf and RPCHTTP.vbs to the same location, or your Outlook Profile has not been configured yet. If you saved the files properly, run Outlook and exit out prior to rerunning this script.",0,cTitle
	EndScript 1010 'Machine Excluded (Due to Exchange Server)
End If

'----------------------------------------------------------------
'Sub EnableUI
'	Turn on the Outlook UI so the user can configure manually
'----------------------------------------------------------------
Sub EnableUI() 'EnableUI
	Dim retVal
	retVal = WriteRegistry("HKCU\Software\Microsoft\Office\11.0\Outlook\RPC\EnableRPCtunnelingUI",1,"REG_DWORD")
End Sub
'----------------------------------------------------------------
'Sub EnableBCM
'	Enable Business Contact Manager Reg Key
'----------------------------------------------------------------
Sub EnableBCM() 'EnableUI
	Dim retVal
	retVal = CreateRegistry("HKLM\software\microsoft\hostedexchange20\")
	
End Sub
'----------------------------------------------------------------
'Sub InstallQFE
'	Install OS QFE, appropriate error handling if failure
'----------------------------------------------------------------
Sub InstallQFE() 'Install QFE
	On Error Resume Next
	Dim sExePath,sSwitches,sCmdLine,retval
	If Not QFE_IsInstalled("Q331320") Then
		sExePath = fso.BuildPath(root,"Q331320.EXE")
		sSwitches = "-u -z"
		sCmdLine = """" & sExePath & """" & " " & sSwitches
		If fso.FileExists(sExePath) Then
			WriteLog "Executing [" & sCmdLine & "]"
			retval=WshShell.Run(sCmdLine,,1)
			WriteLog "Execution of [" & sExePath & "] Finished with a code of " & retval
			If QFE_IsInstalled("Q331320") Then
				bNeedsReboot = TRUE
			End If
		Else
			WriteLog "Hotfix [" & sExePath & "] Not Found."
			wshShell.Popup "A required File, " & sExePath & " could not be found.",0,cTitle
			EndScript 1015
		End If
	End If
End Sub

'----------------------------------------------------------------
'Sub ServerCheck
'	Read the Exchange Server from the default profile
'	and check whether it's a valid profile to configure.
'	Choose the correct PRF file based on the Exchange Server.
'History:	RL - 7/14/03: Removed multiple prf/Exchange Server functionality.
'			Assuming one prf file.
'			RL - 8/11/03: Removed reg read for default profile. Default profile not required.
'----------------------------------------------------------------
Sub ServerCheck() 'Determine Excg Server and copy PRF File (Steps 3 & 4)
	Dim profile,itemArr,lenPrefix,SrvrCnt
	Err.Clear
	On Error Resume Next
	'Assuming a single prf file.
	WriteLog "PRF File: " & sPRFFile 
	'User has to save the prf file to the same folder as vbs file.
	srcPRFFile = fso.BuildPath(root, sPRFFile)
	WriteLog "Source PRF File: " & srcPRFFile
End Sub

'----------------------------------------------------------------
'Sub ReplicatePRF
'	Copy the appropriate PRF file to the user's Application Data directory.
'----------------------------------------------------------------
Sub ReplicatePRF()
		On Error Resume Next
		If (sPRFFile <> "") AND fso.FileExists(srcPRFFile) Then
			dstPRFFile = fso.BuildPath(sUserProfile,"Application Data\Microsoft\Outlook\rpchttp.prf")
			If fso.FileExists(dstPRFFile) Then
				WriteLog "File [" & dstPRFFile & "] already exists. Renaming to [" & dstPRFFile & ".bak]."
				fso.CopyFile dstPRFFile,dstPRFFile & ".bak",TRUE
				fso.DeleteFile dstPRFFile,TRUE
				If fso.FileExists(dstPRFFile) Then
					WriteLog "Unable to delete original [" & dstPRFFile & "]."
				End If 
			End If
			WriteLog "Destination PRF File: " & dstPRFFile
			fso.CopyFile srcPRFFile,dstPRFFile,TRUE
			If fso.FileExists(dstPRFFile) Then
				WriteLog "Copied [" & srcPRFFile & "] to [" & dstPRFFile & "]"
			End If 
		End If
End Sub

'----------------------------------------------------------------
'Sub ImportPRF
'	Set up Outlook to import a PRF file on the next boot.
'----------------------------------------------------------------
Sub ImportPRF() 'Set up the Import
	If fso.FileExists(dstPRFFile) Then
		bManual = Not WriteRegistry("HKCU\Software\Microsoft\Office\11.0\Outlook\Setup\ImportPRF",dstPRFFile,"REG_SZ")
	Else
		bManual = TRUE
		WriteLog "File [" & dstPRFFile & "] doesn't exist.	Not Setting ImportPRF"
	End If
End Sub

'----------------------------------------------------------------
'Sub RemoveFirstRun
'	Delete the Outlook First-Run registry value.
'----------------------------------------------------------------
Sub RemoveFirstRun() 'Remove First Run
	bManual = Not DeleteRegistry("HKCU\Software\Microsoft\Office\11.0\Outlook\Setup\First-Run")
End Sub

'----------------------------------------------------------------
'Sub Finish Dialog
'	Completion Dialog.  Also prompt for reboot if applicable.
'----------------------------------------------------------------
Sub FinishDialog() 'Cause Reboot
	On Error Resume Next
	Dim popret : popret = 0
	Dim spopMsg
	If Not bManual Then
		If bNeedsReboot Then
			popret = WshShell.Popup("Script completed successfully! To complete the configuration of RPC over HTTP, please reboot your machine.  Would you like to reboot now?",0,cTitle,4)
			If popret=6 Then
				doReboot
			End If
		Else
			popret = WshShell.Popup("Script completed successfully! To complete the configuration of RPC over HTTP, please exit and restart Outlook if it's running",0,cTitle)
		End If
	Else
		If bNeedsReboot Then
			sPopMsg = "Setup completed successfully! To complete the installation of RPC over HTTP, please reboot your machine.  Then goto "
			sPopMsg = sPopMsg & fso.GetParentFolderName(dstPRFFile) & " and double click on the rpchttp.prf file."
			sPopMsg = sPopMsg & vbcrlf & "Do you wish to reboot Now?"
			popret=WshShell.Popup(sPopMsg,0,cTitle,4)
			If popret=6 Then
				doreboot
			End If
		Else
			sPopMsg = "Script completed successfully! To complete the installation of RPC over HTTP, please goto "
			sPopMsg = sPopMsg & fso.GetParentFolderName(dstPRFFile) & " and double click on the rpchttp.prf file."
			popret=WshShell.Popup(sPopMsg,0,cTitle)
		End If
	End If
End Sub
		 
'----------------------------------------------------------------
'Sub CreateLog
'	Open the logging file and stamp that we've started.
'----------------------------------------------------------------
Sub CreateLog()
	On Error Resume Next
	If Not IsObject(output) Then
		If fso.FileExists(sLogFile) Then
			set output = fso.OpenTextFile(slogFile,ForAppEnding,True)
		Else
			set output = fso.CreateTextFile(slogfile)
		End If
		If Err <> 0 Then
			output = ""
		Else
			WriteLog "--- Logging Started ---"
			WriteLog "LogFile: " & sLogFile 
		End If
	End If
End Sub

'----------------------------------------------------------------
'Sub WriteLog
'	Write a time/date stamped line to the log
'----------------------------------------------------------------
Sub WriteLog(strMessage)
	On Error Resume Next
	If IsObject(output) Then
		output.WriteLine Now & ": " & strMessage
	End If
	If bDebug Then wscript.echo strMessage
End Sub

'----------------------------------------------------------------
'Sub EndScript
'	Close up the log and end the script
'----------------------------------------------------------------
Sub EndScript(retcode)
	On Error Resume Next
	WriteLog "--- Logging Complete ---"
	WriteLog ""
	StatusMIF "",1
	If isObject(output) Then output.close
	wscript.quit(retcode)
End Sub

'----------------------------------------------------------------
'Sub StatusMIF
'	Currently does nothing
'----------------------------------------------------------------
Sub StatusMIF(strMsg,statusCode)
End Sub

'----------------------------------------------------------------
'Function QFE_IsInstalled
'	Determine whether or not a QFE is installed
'	Return TRUE if installed, FALSE is not
'----------------------------------------------------------------
Function QFE_IsInstalled(sQFE)
	On Error Resume Next
	Dim IsInstalled : IsInstalled = 0
	Dim QFEReg : QFEReg = "HKLM\Software\Microsoft\Windows NT\CurrentVersion\Hotfix"
	Dim sQFERegPath : sQFERegPath = QFEReg & "\" & sQFE & "\Installed"
	QFE_IsInstalled=FALSE
	IsInstalled = wshshell.RegRead(sQFERegPath)
	If Err <> 0 Then
		WriteLog Err & ":" & Err.Description
		If CBool(IsInstalled) Then
			WriteLog "Hotfix " & sQFE & " is Installed."
			QFE_IsInstalled = TRUE
		Else
			WriteLog "Hotfix " & sQFE & " is not Installed."
			QFE_IsInstalled = FALSE
		End If
	Else
		WriteLog IsInstalled & " < "  & sQFERegPath
		WriteLog "Hotfix " & sQFE & " is Installed."
		QFE_IsInstalled = TRUE
	End If
End Function

'----------------------------------------------------------------
'Function doReboot
'	Reboot the system, display error on fail
'----------------------------------------------------------------
Function doReboot()
	Dim oSvc,eOS,oOS
	WriteLog "--- Logging Complete ---"
	WriteLog ""
	StatusMIF "",1
	If isObject(output) Then 
		output.close
		Set output = Nothing
		output = ""
	End If
	On Error Resume Next
	Set oSvc = GetObject("winmgmts:{impersonationLevel=impersonate,(Shutdown)}root/cimv2")
	Set eOS = oSvc.ExecQuery("Select * from Win32_OperatingSystem")
	For Each oOS in eOS
		oOS.Reboot()
	Next 
	If Err <> 0 Then
		wshShell.Popup "Your machine could not be rebooted.  Please reboot at your earliest convenience.",0,cTitle,0
	End If
End Function

'----------------------------------------------------------------
'Function DetectOS
'	Sets global variables
'	osVer, osBuild, osSPMaj, osSPMin, osLanguage
'----------------------------------------------------------------
Function DetectOS()
	On Error Resume Next
	Dim oSvc,eOS,oOS
	Set oSvc = GetObject("winmgmts:{impersonationLevel=impersonate}root/cimv2")
	Set eOS = oSvc.ExecQuery("Select * from Win32_OperatingSystem")
	For Each oOS in eOS
		osVer = oOS.Version
		If Len(osVer) >= 3 Then osVer=Left(osVer,3)
		WriteLog "Operating System Version: " & osVer
		osBuild = oOS.BuildNumber
		WriteLog "Operating System Build: " & osBuild
		osCSDVer = oOS.CSDVersion
		osSPMaj = oOS.ServicePackMajorVersion
		WriteLog "Operating System SP: " & osSPMaj
		osSPMin = oOS.ServicePackMinorVersion
		WriteLog "Operating System Minor SP: " & osSPMin
		osLanguage = oOS.OSLanguage
		WriteLog "Operating System Language: " & osLanguage
	Next 
End Function

'----------------------------------------------------------------
'Function CheckProductCode
'  Returns: TRUE if ProductCode Matches the CodeTemplate
'           FALSE Otherwise
'  Where CodeTemplate is in the format of
'  {????????-XXXX-XXXX-XXXX-XXXXXXXXXXXXX} 
'    where a '?' designates a wildcard, and the 'X' represents a
'    Hexadecimal Digit
'----------------------------------------------------------------
Function CheckProductCode(ProductCode,CodeTemplate)
	Dim Count, bNoMatch, i
	if bDebug Then wscript.echo ProductCode & "---" &CodeTemplate
	CheckProductCode = FALSE
	Count = len(CodeTemplate)
	If len(ProductCode) = Count Then
		bNoMatch = FALSE
		for i = 1 to Count
		If Not bNoMatch Then
			If bDebug Then wscript.echo mid(CodeTemplate,i,1) &  " - = - " & mid(ProductCode,i,1)
			If mid(CodeTemplate,i,1) <> "?" Then
				If mid(CodeTemplate,i,1) <> mid(ProductCode,i,1) Then
					If bDebug Then wscript.echo "No Match at " & i
					bNoMatch = TRUE
				End If
			End If
		End If
		next
		If Not bNoMatch Then CheckProductCode = TRUE
	End If
End Function

'----------------------------------------------------------------
'Function IsOffice11Installed
'	Returns TRUE if product code of Off11FamilyCode exists
'	Returns FALSE if Office 11 MSI product code not found
'----------------------------------------------------------------
Function IsOffice11Installed()
	IsOffice11Installed = FALSE
	Dim eProds,oProd
	Set eProds = msi.Products
	For Each oProd in eProds
		If CheckProductCode(oprod,Off11FamilyCode) Then 
			IsOffice11Installed = TRUE
			Exit For
		End If
	Next
End Function

'----------------------------------------------------------------
'Function WriteRegistry
'	Returns TRUE if registry value was written successfully
'	Returns FALSE on error and logs
'----------------------------------------------------------------
Function WriteRegistry(regVal,regData,regType)
	WriteRegistry = TRUE
	On Error Resume Next
	Dim regEntry
	regEntry = wshShell.RegRead(regVal)
	If Err = 0 Then
		WriteLog "[" & regEntry & "]" & " < " & regVal
	Else
		WriteLog "[] < " & regVal
	End If
	Err.Clear
	wshShell.RegWrite regVal,regData,regType
	regEntry = wshShell.RegRead(regVal)
	If Err = 0 Then
		WriteLog "[" & regEntry & "]"  & " > " & regVal
	Else
		WriteRegistry = FALSE
		WriteLog "Error: " & Err & ":" & Err.Description
		WriteLog "[] > " & regVal
	End If
	Err.Clear
End Function

'----------------------------------------------------------------
'Function DeleteRegistry
'	Returns TRUE if registry value was deleted successfully
'	Returns FALSE on error and logs
'----------------------------------------------------------------
Function DeleteRegistry(regVal)
	DeleteRegistry = TRUE
	On Error Resume Next
	Dim regEntry
	wshShell.RegDelete regVal
	If Err <> 0 Then
		If Err = &H80070002 Then
			WriteLog "Registry " & regVal & " was not Present."
		End If
	End If
	regEntry = wshShell.RegRead(regVal)
	If regEntry <> "" Then DeleteRegistry = FALSE
	Err.Clear
End Function
'----------------------------------------------------------------
'Function CreateRegistry
'	Returns TRUE if registry value was created successfully
'	Returns FALSE on error and logs
'----------------------------------------------------------------
Function CreateRegistry(regKey)
	CreateRegistry = TRUE
	On Error Resume Next
	Dim regEntry
	wshShell.RegWrite regKey,"1","REG_SZ"
	If Err <> 0 Then
			WriteLog "Failed to create " & regKey & "."
	End If
	regEntry = wshShell.RegRead(regVal)
	If regEntry <> "" Then CreateRegistry = TRUE
	Err.Clear
End Function