Environment: Windows XP, Outlook, vb-script
Description: This script is run from Active Directory Group Policy log on script to disable Outlook personal mailbox files, pst files. The script includes a built-in method to deploy to pilot group. To make trouble shooting easier, all steps are written to application event log
Code:
'=========================================================================
' FILE : UserOutlookRemovePSTref.vbs
' AUTHOR : Robert Lawson
' COMPANY: Soka University of America
' DATE : 12/02/2006 Robert Lawson Creation Date
' COMMENT: Remove PST file references in Outlook profile
' Note, after this is run, the only repair to the Outlook profile is to delete it
' Office 2003 only (Office Versions: 11.0 = 2003; 10.0 = XP)
' Assume: 1) Outlook installed, 2) Outlook has been opened
' ' http://www.codecomments.com/message383229.html primary source of info
'=========================================================================
option explicit
On Error Resume Next ' Required
const conScriptName = "UserOutlookRemovePSTref.vbs"
const conDEBUG = FALSE
const conUpdateRegKeys = TRUE ' TRUE = will update Outlook reg keys
const conPilot = TRUE ' TRUE = script for pilot group of users, FALSE= all users considered
Dim strMsg, intLoc, objShell
Dim objNetwork, strUserName, strUserDomain, strGroupName, strComputerName
DIM Result, objReg, Return, strComputer, junk, count
Dim arrEntrynames(),Profile, arrProfiles(), ProfileSubkey, arrProfileSubKeys(), arrValueTypes(), arrValue
Dim strPSTFileName, strPSTRefence, strPSTKey, strRemoveKey, strKey
Const conOutlookProfileKey = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\"
Const HKCR=&H80000000 'HKEY_CLASSES_ROOT
Const HKCU=&H80000001 'HKEY_CURRENT_USER
Const HKLM=&H80000002 'HKEY_LOCAL_MACHINE
Const HKU=&H80000003 'HKEY_USERS
Const HKCC=&H80000005 'HKEY_CURRENT_CONFIG
' ============================================================
' Setup
' ============================================================
Set objShell = CreateObject( "WScript.Shell" )
Set objNetwork = Wscript.CreateObject("Wscript.Network")
strComputer = "."
Set objReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
strMsg = "BEGIN: " & conScriptName
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
strComputerName = objNetwork.ComputerName
strUserName = objNetwork.UserName
strUserDomain = objNetwork.UserDomain
strMsg = conScriptName & " values: CN = " & strComputerName & "; UN = " & strUserName & "; DN = " & strUserDomain
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
if (conPilot and NOT PilotByList(strUserName)) then
strMsg = conScriptName & "; Stopped. User not part of pilot group. User = " & strUserName
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
Wscript.Quit
end if ' Pilot
' ============================================================
' Main:
' ' Enumerate each Outlook profile for this user
' ' Remove key with PST file reference
' ============================================================
objReg.EnumKey HKCU, conOutlookProfileKey, arrProfiles
For Each Profile in arrProfiles
if conDEBUG then Wscript.Echo "Profile = " & Profile
objReg.EnumKey HKCU, conOutlookProfileKey & Profile & "\", arrProfileSubKeys
For Each ProfileSubkey In arrProfileSubKeys
strMsg = "ProfileSubkey = " & ProfileSubkey
if conDEBUG then Wscript.Echo strMsg
objReg.EnumValues HKCU,conOutlookProfileKey & Profile & "\" & ProfileSubKey & "\",arrEntryNames,arrValueTypes
Err.Clear
junk = UBound(arrEntryNames) ' Ignore keys that have no entries.
If Err.Number = 0 Then
strPSTFileName = ""
strPSTRefence = ""
strPSTKey = ProfileSubkey
For Count=0 To UBound(arrEntryNames)
' 001f6700 = Fully qualified file name
strKey = "001f6700"
If arrEntryNames(Count) = strKey Then
objReg.GetBinaryValue HKCU,conOutlookProfileKey & Profile & "\" & ProfileSubKey & "\",strKey,arrValue
strPSTFileName = BinaryToString(arrValue)
End If
' 001f3006 = Name of reference in Outlook
strKey = "001f3006"
If arrEntryNames(Count) = strKey Then
objReg.GetBinaryValue HKCU,conOutlookProfileKey & Profile & "\" & ProfileSubKey & "\",strKey,arrValue
strPSTRefence = BinaryToString(arrValue)
end if
Next ' UBound(arrEntryNames)
' Remove key(s) with PST file reference.
if LEN(strPSTFileName) > 0 then
strMsg = "*strPSTKey = " & strPSTKey & "; strPSTFileName = " & strPSTFileName & "; strPSTRefence =" & strPSTRefence
if conDEBUG then Wscript.Echo strMsg
strRemoveKey = conOutlookProfileKey & Profile & "\" & strPSTKey
strMsg = "*strRemoveKey = " & strRemoveKey
if conDEBUG then Wscript.Echo strMsg
if conUpdateRegKeys then
Return = objReg.DeleteKey(HKCU, strRemoveKey)
If (Return = 0) And (Err.Number = 0) Then
strMsg = conScriptName & ": REMOVED KEY: = " & strRemoveKey
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
strMsg = conScriptName & ": strPSTFileName = " & strPSTFileName & "; strPSTRefence =" & strPSTRefence
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
Else
Wscript.Echo conScriptName & ": DeleteKey failed. Error = " & Err.Number & " on key = " & strRemoveKey
objShell.LogEvent 0,strMsg
End If
end if
end if
End If
Next ' arrProfileSubKeys
Next ' arrProfiles
' ============================================================
' The End
' ============================================================
strMsg = "END: " & conScriptName
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
set objShell = nothing
Set objNetwork = Nothing
set objReg = nothing
' ============================================================
' Functions: BinaryToString
' ============================================================
Function BinaryToString(val)
Dim bByte, retval, i
For i = 0 To (UBound(val)-2) Step 2
bByte = val(i)
If bByte <> "" Then retval = retval & Chr(bByte)
Next
BinaryToString = retval
End Function
' ============================================================
' Function: PilotByList
' ============================================================
Function PilotByList(strUserID)
' PilotByList: determine pilot group by list of users
' strUserID String Passed User Network ID (sAMAccountname)
' PilotByList Boolean Returned TRUE=UserID is part of pilot group, FALSE=it aint
Dim strUser
PilotByList = FALSE ' default
strUser = lcase(strUserID) ' only lower case
PilotByList = ( _
strUser = "sleepy" or _
strUser = "sneezy" or _
strUser = "weepy" or _
strUser = "dopey" or _
strUser = "grumpy")
End Function ' PilotByList
