UserOutlookRemovePSTref.vbs: Remove Outlook pst features

Author: Robert Lawson
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

UserOutlookEAS.vbs: Install EAS Outlook client

Author: Robert Lawson
Environment: Windows XP, Outlook , EAS, vb-script
Description: This installs the EAS client for Outlook users in a given Active Directory OU, if they are a member of an EAS group. This script is run as Active Directory Group Policy log on script, and to make trouble shooting easier, all steps are written to application event log.
Code:

'=========================================================================
' VBScript Source File -- Created with XLnow OnScript
' FILE   : UserOutlookEAS.vbs
' AUTHOR : Robert Lawson
' COMPANY: Soka University of America
' DATE   :  6/19/2006  Robert Lawson Creation Date
'          11/20/2006  Robert Lawson Always do Outlook updates, improved on EAS logic
'          12/01/2006  Robert Lawson Added disable menu and remove pst references
' COMMENT: Manage EAS deployment: installing EAS client, and making Outlook setting
' conUpdateRegKeys controls if this will update registry keys (Outlook settings)
' Office 2003 only (Office Versions: 11.0 = 2003; 10.0 = XP)
' Registry keys are not setup by default by Outlook

'=========================================================================
option explicit
On Error Resume Next ' Required for reading registry
const conScriptName = "UserOutlookEAS.vbs"
const conDEBUG = FALSE
const conUpdateRegKeys = TRUE ' TRUE = will update Outlook reg keys

Dim strMsg, intLoc
Dim objShell, varTemp, bolRegKeyExists, varNewValue
Dim objFSO, objTS, objExecute
Dim bolOutlookInstalled, bolZantazClientInstalled, bolEASUser
Dim objNetwork, strUserName, strUserDomain, strGroupName, strComputerName
Dim strOU, strFilter, strQuery, rs, objCommand, UserADsPath, objUser, objConnection, objGroup, strKey

const conOutlookRegistryKey = "HKCU\Software\Microsoft\Office\11.0\Outlook\OutlookName"
const conOutlookDisableAutoArchiveKey = "HKCU\Software\Microsoft\Office\11.0\Outlook\Preferences\DoAging"
const conOutlookDisableCreatePSTfilesKey = "HKLM\SOFTWARE\Microsoft\Office\11.0\Outlook\DisablePST"
const conOutlookDisabledCmdBarKey = "HKEY_CURRENT_USER\Software\Policies\Microsoft\Office\11.0\Outlook\DisabledCmdBarItemsList"
const conZantazFile = "C:\Program Files\ZANTAZ\EAS Client\EASCOMPRESS.dll"
const conEASclient = "\\server3\Client\uniClient.msi"
const conRegKeyYes = 1
const conEASGroup = "EASUser"

' Window stype to run
const WINDOWHIDDEN = 0
const WINDOWNORMAL = 1
const WINDOWMINIMIZE = 2
Const ADS_SCOPE_SUBTREE = 2

' ============================================================
' Setup
' ============================================================
Set objShell = CreateObject( "WScript.Shell" )
Set objNetwork = Wscript.CreateObject("Wscript.Network")

set objConnection=Createobject("ADODB.Connection")
set objCommand=CreateObject("ADODB.Command")
objConnection.Provider="ADSDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

strMsg = "BEGIN: " & conScriptName
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg

' ============================================================
' Determine if EAS User (determined by AD group membership)?
' ============================================================
' Get User Info from Network log in
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

' Get User Active Directory information
bolEASUser = FALSE
strOU = "DC=uni,DC=edu"
strFilter = "sAMAccountName = " & "'" & strUserName & "'"
strQuery = "SELECT ADsPath FROM 'LDAP://" & strOU & "' WHERE " & strFilter

strMsg = conScriptName & ": LDAP strQuery = " & strQuery
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg

objCommand.CommandText= strQuery
objCommand.Properties("Searchscope") =    ADS_SCOPE_SUBTREE
Set rs = objCommand.Execute
if rs.EOF or rs.BOF then
 intLoc = 5
 strMsg = conScriptName & ": Error @ " & intLoc & ".  Unabled to get AD user for " & strUserName
 if conDEBUG then Wscript.Echo strMsg
 objShell.LogEvent 0,strMsg
else
 ' Verify if user is member of an EAS group
 UserADsPath = rs.fields("ADsPath").value
 Set objUser = GetObject(UserADsPath)

 For Each objGroup In objUser.Groups
  ' sample: "CN=grpPeopleSoftDBTech"
  strGroupName = objGroup.Name
  if conDEBUG then Wscript.Echo strGroupName
  bolEASUser = (instr(1,strGroupName,conEASGroup) > 0)
  if bolEASUser then Exit For
 Next
end if
strMsg = conScriptName & ": bolEASUser = " & bolEASUser
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg

' ============================================================
' Is Outlook installed for this computer user?
' ============================================================
varTemp = objShell.RegRead (conOutlookRegistryKey)
bolOutlookInstalled = (Err.number= 0)
if conDEBUG then Wscript.Echo " bolOutlookInstalled= " &  bolOutlookInstalled

' ============================================================
' Is Zantaz EAS client installed on this computer?  If not, do so
' ============================================================
set objFSO = CreateObject("Scripting.FileSystemObject")
bolZantazClientInstalled = (objFSO.FileExists(conZantazFile))
strMsg = conScriptName & ": bolOutlookInstalled = " & bolOutlookInstalled & "; conUpdateRegKeys = " & conUpdateRegKeys & _
  "; bolZantazClientInstalled = " & bolZantazClientInstalled
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg

' Need to install EAS client?
if bolOutlookInstalled and Not bolZantazClientInstalled then
 set objFSO = CreateObject("Scripting.FileSystemObject")
 if (objFSO.FileExists(conEASclient)) then
  objShell.Run conEASclient, WINDOWHIDDEN, True
  if err.number = 0 then
   strMsg = conScriptName & ": Installed successfully " & conEASclient
   if conDEBUG then Wscript.Echo strMsg
   objShell.LogEvent 0,strMsg
   bolZantazClientInstalled = TRUE
     else
   intLoc = 10
   strMsg = conScriptName & ": Error @ " & intLoc & " Num = " & Err.number & " " & Err.Description
   DoError(strMsg) ' Failed to execute
  end if
 else
  intLoc = 15
  strMsg = conScriptName & ": Error @ " & intLoc & ".  File does not exist " & conEASclient
  DoError(strMsg) ' File does not exist
 end if
end if

' ============================================================
' Update Outlook Registry Entries?
' ============================================================
if bolOutlookInstalled and conUpdateRegKeys then
 ' Disable auto archive features? 1=yes, 0=no (if no registry, treated as = 0)
 varTemp = ""
 varTemp = obJShell.RegRead(conOutlookDisableAutoArchiveKey)
 bolRegKeyExists = (err.number = 0)
 err.Clear
 if Not bolRegKeyExists or (varTemp <> conRegKeyYes) then
  objShell.RegWrite conOutlookDisableAutoArchiveKey, conRegKeyYes, "REG_DWORD"
  if err.number = 0 then
   strMsg = conScriptName & ": Updated registry " & conOutlookDisableAutoArchiveKey
   if conDEBUG then Wscript.Echo strMsg
   objShell.LogEvent 0,strMsg
     else
   intLoc = 20
   strMsg = conScriptName & ": Error @ " & intLoc & " Num = " & Err.number & " " & Err.Description
   DoError(strMsg) ' Failed to execute
  end if
 else
  strMsg = conScriptName & ": Registry not updated, value already set for  " & conOutlookDisableAutoArchiveKey
  if conDEBUG then Wscript.Echo strMsg
  objShell.LogEvent 0,strMsg
 end if

 ' Disable creating any pst files? 1=yes, 0=no (if no registry, treated as = 0)
 varTemp = ""
 varTemp = obJShell.RegRead(conOutlookDisableCreatePSTfilesKey)
 bolRegKeyExists = (err.number = 0)
 err.Clear
 if Not bolRegKeyExists or (varTemp <> conRegKeyYes)  then
  objShell.RegWrite conOutlookDisableCreatePSTfilesKey, conRegKeyYes, "REG_DWORD"
  if err.number = 0 then
   strMsg = conScriptName & ": Updated registry " & conOutlookDisableCreatePSTfilesKey
   if conDEBUG then Wscript.Echo strMsg
   objShell.LogEvent 0,strMsg
     else
   intLoc = 23
   strMsg = conScriptName & ": Error @ " & intLoc & " Num = " & Err.number & " " & Err.Description
   DoError(strMsg) ' Failed to execute
  end if
 else
  strMsg = conScriptName & ": Registry not updated, value already set for  " & conOutlookDisableCreatePSTfilesKey
  if conDEBUG then Wscript.Echo strMsg
  objShell.LogEvent 0,strMsg
 end if

 ' Disable Outlook menu items  KB309136
    ' TCID1 5575 Disable option to create a PST (File>New>Outlook Data File)
    ' TCID2 5576 Disable option to open a PST (File>Open>Outlook Data File)
 strKey = conOutlookDisabledCmdBarKey & "\TCID1"  ' Unique value for menu disable
 varNewValue = "5575" ' Disable option to create a PST              
 objShell.RegWrite strKey, varNewValue, "REG_SZ"
 if err.number = 0 or err.number = 500 then
  err.Clear
  strMsg = conScriptName & ": Updated registry " & strKey
  if conDEBUG then Wscript.Echo strMsg
  objShell.LogEvent 0,strMsg
    else
  intLoc = 25
  strMsg = conScriptName & ": Error @ " & intLoc & " Num = " & Err.number & " " & Err.Description
  DoError(strMsg) ' Failed to execute
 end if

 strKey = conOutlookDisabledCmdBarKey & "\TCID2" ' Unique value for menu disable
 varNewValue = "5576"   ' Disable option to open a PST           
 objShell.RegWrite strKey, varNewValue, "REG_SZ"
 if err.number = 0 or err.number = 500 then
  err.Clear
  strMsg = conScriptName & ": Updated registry " & strKey
  if conDEBUG then Wscript.Echo strMsg
  objShell.LogEvent 0,strMsg
    else
  intLoc = 30
  strMsg = conScriptName & ": Error @ " & intLoc & " Num = " & Err.number & " " & Err.Description
  DoError(strMsg) ' Failed to execute
 end if
end if ' Registry Entry update

' ============================================================
' The End
' ============================================================
strMsg = "END: " & conScriptName
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg

Set objNetwork = Nothing

' ======================================================
Function DoError(strErrMsg)
On Error Resume Next
Dim objShell

if conDEBUG then Wscript.Echo strErrMsg

Set objShell=CreateObject("wscript.shell")
objShell.LogEvent 1,strErrMsg
End Function

FindPST.cmd: Find Outlook pst files on user's computer

Author: Robert Lawson
Environment: Windows Server, Active Directory
Description: This script was used to find pst files on user's desktop systems. This was used with a higher level script that included all employee's and their comptuer name. This was final phase of getting all Outlook pst files back into our Exchange/EAS email system.
Code:

rem FindPST.cmd
rem Parm1  Computer Name     Required
rem Parm2  Domain Admin User Required
rem Parm3  DA password       Required
rem T:w (last written to), T:a (last access)
ECHO Checking %1 on C drive on %DATE% at %TIME%
ECHO Checking %1 on C drive on %DATE% at %TIME%>>FindPST.txt
PING %1>> FindPST.txt
NET USE \\%1\ipc$ %3 /USER:soka\%2
DIR \\%1\c$\*.pst /S /Q /T:w>> FindPST.txt
NET USE \\%1\ipc$ /DELETE