How to Add Outlook Address Book using VBScript?

[RichAllen]

Hello,

I have read through the articl
http://www.outlookcode.com/codedetail.aspx?id=1243 on how to add a
LDAP Address Book.

I have a similar problem in that I need to add the Outlook Address Boo
to several hundred users who are missing the service from thei
profiles.

I have hunted far and wide for a way to do this, spent many many hour
tracking down which registry keys are modified when this service i
added.

Below is pasted the reg file that will add the service on a brand-ne
profile. The problem comes with pre-existing profiles that already hav
other settings stored in these keys.

I have kind of figured out that the services are enumerated in key
under the "HKEY_CURRENT_USER\Software\Microsoft\Window
NT\CurrentVersion\Windows Messagin
Subsystem\Profiles\Outlook\9375CFF0413111d3B88A00104B2A6676" key
though I am not entirely sure how I get Outlook to look into a key
create here but even more importantly, how to add test if this servic
is running, then if not, how to add it without blasting all othe
settings.

If anyone has thoughts/advice/examples on this I will be eternall
grateful!


Reg file:

[HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Window
Messagin
Subsystem\Profiles\Outlook\9375CFF0413111d3B88A00104B2A6676\00000001]
"clsid"="{ED475414-B0D6-11D2-8C3B-00104B2A6676}"
"Mini UID"=dword:e1663bcc
"Service Name"=hex:43,00,4f,00,4e,00,54,00,41,00,42,00,00,00
"Service UID"=hex:bf,e5,57,d6,84,b6,c5,46,a6,5a,7c,20,78,07,61,5e
"MAPI Provider"=dword:00000002
"Accoun
Name"=hex:4f,00,75,00,74,00,6c,00,6f,00,6f,00,6b,00,20,00,41,00,64,00,\
64,00,72,00,65,00,73,00,73,00,20,00,42,00,6f,00,6f,00,6b,00,00,00

[HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Window
Messaging Subsystem\Profiles\Outlook\bfe557d684b6c546a65a7c207807615e]
"001f3d0a"=hex:63,00,6f,00,6e,00,74,00,61,00,62,00,2e,00,64,00,6c,00,6c,00,00,\
00
"001f3d13"=hex:7b,00,36,00,34,00,38,00,35,00,44,00,32,00,36,00,36,00,2d,00,43,\

00,32,00,41,00,43,00,2d,00,31,00,31,00,44,00,31,00,2d,00,41,00,44,00,33,00,\

45,00,2d,00,31,00,30,00,41,00,30,00,43,00,39,00,31,00,31,00,43,00,39,00,43,\
00,30,00,7d,00,00,00
"101e3d0f"=hex:01,00,00,00,08,00,00,00,63,6f,6e,74,61,62,2e,64,6c,6c,00
"001f3d0b"=hex:53,00,65,00,72,00,76,00,69,00,63,00,65,00,45,00,6e,00,74,00,72,\
00,79,00,00,00
"00033009"=hex:22,00,00,00
"001f3d09"=hex:43,00,4f,00,4e,00,54,00,41,00,42,00,00,00
"001f3001"=hex:4f,00,75,00,74,00,6c,00,6f,00,6f,00,6b,00,20,00,41,00,64,00,64,\
00,72,00,65,00,73,00,73,00,20,00,42,00,6f,00,6f,00,6b,00,00,00
"01023d01"=hex:e7,b9,28,a9,9b,b4,6a,4c,b5,00,97,de,ed,9d,3d,59

[HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Window
Messaging Subsystem\Profiles\Outlook\9207f3e0a3b11019908b08002b2a56c2]
"01023d01"=hex:e7,b9,28,a9,9b,b4,6a,4c,b5,00,97,de,ed,9d,3d,59,ff,bc,4d,6f,ca,\
12,d8,4a,b9,04,ab,ac,20,ea,fe,2f
"01023d0e"=hex:bf,e5,57,d6,84,b6,c5,46,a6,5a,7c,20,78,07,61,5e,94,c7,1c,58,55,\
9a,2b,43,aa,1a,ad,5a,18,30,c9,c5

[HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Window
Messaging Subsystem\Profiles\Outlook\e7b928a99bb46a4cb50097deed9d3d59]
"001f300a"=hex:63,00,6f,00,6e,00,74,00,61,00,62,00,2e,00,64,00,6c,00,6c,00,00,\
00
"001f3d13"=hex:7b,00,36,00,34,00,38,00,35,00,44,00,32,00,36,00,36,00,2d,00,43,\

00,32,00,41,00,43,00,2d,00,31,00,31,00,44,00,31,00,2d,00,41,00,44,00,33,00,\

45,00,2d,00,31,00,30,00,41,00,30,00,43,00,39,00,31,00,31,00,43,00,39,00,43,\
00,30,00,7d,00,00,00
"00033e03"=hex:23,00,00,00
"001f3006"=hex:4f,00,75,00,74,00,6c,00,6f,00,6f,00,6b,00,20,00,41,00,64,00,64,\
00,72,00,65,00,73,00,73,00,20,00,42,00,6f,00,6f,00,6b,00,00,00
"01023d0c"=hex:bf,e5,57,d6,84,b6,c5,46,a6,5a,7c,20,78,07,61,5e
"001f3d09"=hex:43,00,4f,00,4e,00,54,00,41,00,42,00,00,00
"001f3001"=hex:4f,00,75,00,74,00,6c,00,6f,00,6f,00,6b,00,20,00,41,00,64,00,64,\
00,72,00,65,00,73,00,73,00,20,00,42,00,6f,00,6f,00,6b,00,00,00
"00033009"=hex:00,00,00,00
"01026601"=hex:35,e0,c0,7f,3e,ac,1f,43,ad,3d,83,41,2b,f8,a6,9

 

[RichAllen]

Script (part 2):


'=============================================================================================================================================================
'
' Function GetProfileKey()
'
' This returns the full path to the settings key for the defaul
Outlook profile
'
'=============================================================================================================================================================

Function GetProfileKey() ' String
GetProfileKey = PROFILE_KEY & GetDefaultProfile()
End Function

'=============================================================================================================================================================
'
' Function GetDefaultProfile() & GetFirstProfile()
'
' This will read the default outlook profile name from the registry
if the value is blank it finds the first profile in the key (as
subkey of the profile key)
'
'=============================================================================================================================================================

Function GetDefaultProfile() ' String
Dim oWshShell ' WshShell
Err.Clear
On Error Resume Next
Set oWshShell = CreateObject("Wscript.Shell")
GetDefaultProfile = oWshShell.RegRead(PROFILE_KEY
"DefaultProfile")
If GetDefaultProfile = "" Then GetDefaultProfile = GetFirstProfile
Err.Clear
Set oWshShell = Nothing
End Function

Function GetFirstProfile() ' String
Dim oReg
Dim arrSubKeys

Const HKEY_CURRENT_USER = &H80000001
On Error Resume Next

Set oReg
GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
oReg.EnumKey HKEY_CURRENT_USER, Replace(PROFILE_KEY
"HKEY_CURRENT_USER\", ""), arrSubKeys
GetFirstProfile = arrSubKeys(0)
Erase arrSubKeys
Set oReg = Nothing
Err.Clear
End Function

'=============================================================================================================================================================
'
' Function HasRun(strKey, intStampVersion)
'
' This will read the stamp set by previous runs of the config script
' To release updates simply increment the intStampVersion in the call
' To rerun the current config on a pc, delete the stamp key or set th
value to zero
'
'=============================================================================================================================================================

Function HasRun(strKey, intStampVersion)

Dim oWshShell ' WshShell

Err.Clear
On Error Resume Next

Set oWshShell = CreateObject("Wscript.Shell")
HasRun = (CInt(oWshShell.RegRead(strKey)) >= intStampVersion)

If Err.Number <> 0 Then StampKey strKey, 0 ' Add the key if i
doesn't exist

Err.Clear
Set oWshShell = Nothing

End Function

'=============================================================================================================================================================
'
' Sub StampKey(strKey, intStampVersion)
'
' This will set the value in the stamp key tested by the HasRu
function
' In each subsequent update, increment the stamp version by one
'
'=============================================================================================================================================================

Sub StampKey(strKey, intStampVersion)
Dim oWshShell ' WshShell

Err.Clear
On Error Resume Next

Set oWshShell = CreateObject("Wscript.Shell")
oWshShell.RegWrite strKey, intStampVersion
Set oWshShell = Nothing

'Error Handler
If Err.Number <> 0 Then
Set oWshShell = CreateObject("WScript.Shell")
oWshShell.LogEvent 1, "Login Script: Outlook Configuratio
Script: StampKey subroutine: failed with the following error: "
vbCrLf & _
Err.Number & " - " & Err.Source & ": "
Err.Description
' Tidy Up
Set oWshShell = Nothing
End If

End Sub

'=============================================================================================================================================================
'
' Function GetTEMPDIR()
'
' Returns string as path to the user's TEMP folder as listed in the
user environment variable
' If TEMP does not exist for some reason TMP is tried, if this too does
not exist then it defaults back My Documents
' Environment Strings such as %USERPROFILE% are replaced by their
literal value
'
'=============================================================================================================================================================

Function GetTEMPDIR()
Dim oWshShell ' WshShell
Dim oEnv ' WshShell Environment Object
Dim RootPath ' String

Set oWshShell = CreateObject("WScript.Shell")
Set oEnv = oWshShell.Environment("User")
GetTEMPDIR = oEnv("TEMP")
If GetTEMPDIR = "" Then
GetTEMPDIR = oEnv("TMP")
If GetTEMPDIR = "" Then
GetTEMPDIR = oWshShell.SpecialFolders("MyDocuments")
End If
End If
If InStr(GetTEMPDIR, "%") Then
RootPath = oWshShell.ExpandEnvironmentStrings(Split(GetTEMPDIR,
"\")(0))
GetTEMPDIR = Replace(GetTEMPDIR, Split(GetTEMPDIR, "\")(0),
RootPath)
End If
Set oEnv = Nothing
Set oWshShell = Nothing

End Function

'=============================================================================================================================================================
'
' Sub DeleteProfileBackup(strProfile)
'
' Kills off the registry key created by Outlook as a copy of the
profile being modified when it imports a PRF file (called 'BACKUP OF
<modified profile name>'
' Writing a reg file to do this is the quickest way to kill off a hive,
WshShell.RegDelete will only remove a key with no subkeys
' Could use WMI to recurse through all the subkeys and remove them but
this is quicker and more robust
'
'=============================================================================================================================================================

Sub DeleteProfileBackup(strProfile)
Dim oWshShell ' WshShell
Dim oFSO ' FileSystemObject
Dim oTxtStream ' TextStream
Dim st_TEMPFILE ' String

Err.Clear
On Error Resume Next

Set oWshShell = CreateObject("Wscript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
st_TEMPFILE = GetTEMPDIR & "\KillBackupProfile.reg"
Set oTxtStream = oFSO.CreateTextFile(st_TEMPFILE, True)
oTxtStream.WriteLine ("Windows Registry Editor Version 5.00" &
vbCrLf)
oTxtStream.WriteLine ("[" & PROFILE_KEY & "]")
oTxtStream.WriteLine
("[-HKEY_CURRENT_USER\Software\Microsoft\Windows
NT\CurrentVersion\Windows Messaging Subsystem\Profiles\BACKUP OF " &
strProfile & "]")
oTxtStream.Close
Set oTxtStream = Nothing

Set oWshShell = CreateObject("Wscript.Shell")
oWshShell.Run "regedit /s " & oFSO.GetFile(st_TEMPFILE).ShortPath,
1, True
Set oWshShell = Nothing

oFSO.DeleteFile st_TEMPFILE

' Tidy Up
Set oFSO = Nothing
Set oTxtStream = Nothing

'Error Handler
If Err.Number <> 0 Then
Set oWshShell = CreateObject("WScript.Shell")
oWshShell.LogEvent 1, "Login Script: Outlook Configuration
Script: DeleteProfileBackup subroutine: failed with the following
error: " & vbCrLf & _
Err.Number & " - " & Err.Source & ": " &
Err.Description
Set oWshShell = Nothing
End If
End Sub