Scripts included in 
Configuring Microsoft Outlook 2003
by Sue Mosher with Robert Sparnaaij, Charlie Pulfer, and David Hooker
ISBN 155583261

Details on the requirements and usage for each script are found on the 
indicated page of the book. No warranty is made for the appropriateness
of these scripts for any particular configuration scenario. 
 

Listing 4.2 [page 151]
======================

var stdin = WScript.StdIn;
var stdout = WScript.StdOut;
var WshShell = WScript.CreateObject("WScript.Shell")

var str2
while (!stdin.AtEndOfStream)
{
     var str = stdin.ReadLine();
     str2 = WshShell.ExpandEnvironmentStrings(str)
     stdout.WriteLine(str2)
}


Listing 4.3 [page 152]
======================

setlocal
set accountname=Abraham Lincoln
set imapserver=server1
set smtpserver=server2
set imapuser=AbeL
set emailaddress=AbeL@somedomain.com
set username=Lincoln
set userprofile=
cscript /nologo SubstEnv.js < template_file.prf > output_file.prf
endlocal


Listing 4.5 [page 154]
======================

Dim userPath
Call AddPSTsToPRF( _
  "C:\Program Files\Microsoft Office\" & _
  "Office11\basic new Exchange.prf", _
  "installme.prf")

Sub AddPSTsToPRF(prfPath, prfOutputFile)
    Const FORREADING = 1
    Const FORWRITING = 2 

    arrPST = FindPSTs()
    For i = 0 To UBound(arrPST)
        strServiceList = strServiceList & vbCrLf & _
                         "ServicePST" & i & _
                         "=Unicode Personal Folders"
        strServices = strServices & vbCrLf & _
                      "[ServicePST" & i & "]" & _
                      vbCrLf & "UniqueService=No" & _
                      vbCrLf & _
                      "PathToPersonalFolders=" & _
                      userPath & arrPST(i) & vbCrLf
    Next
  
    If Len(strServiceList) > 2 Then
        strServiceList = Mid(strServiceList, 3)
        strServices = Mid(strServices, 3)
    
        Set fso = _
          CreateObject("Scripting.FileSystemObject")
        Set prfFile = fso.GetFile(prfPath)
        If Not prfFile Is Nothing Then
            Set ts = _
              prfFile.OpenAsTextStream(ForReading)
            prfContents = ts.ReadAll
            prfContents = Replace(prfContents, _
                            "[Service List]", _
                            "[Service List]" & _
                            vbCrLf & strServiceList, _
                            1, 1, vbTextCompare)
            prfContents = Replace(prfContents, _
                            ";[ServiceX]", _
                            strServices & vbCrLf & _
                            ";[ServiceX]", _
                            1, 1, vbTextCompare)
            ts.Close

            Set ts = fso.CreateTextFile(userPath & _
                       prfOutputFile, True)
            ts.Write prfContents
            ts.Close
        End If
    End If
End Sub

Function FindPSTs()
    ' get path to default location for PST files
    Set WshShell = CreateObject("WScript.Shell")
    userPath = WshShell.expandenvironmentstrings _
                 ("%userprofile%") & _
                 "\Local Settings\Application Data" & _
                 "\Microsoft\Outlook\"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(userPath)
    
    For Each myFile In fld.Files
        If Right(UCase(myFile.Name), 4) = ".PST" Then
            days = DateDiff("d", _
                     myFile.DateLastModified, Date)
            If days < 31 Then
                If Left(myFile.Name, 18) <> _
                  "SharePoint Folders" Then
                    strFileList = strFileList & ";" & _
                                  myFile.Name
                End If
            End If
        End If
    Next
    If strFileList <> "" Then
        strFileList = Mid(strFileList, 2)
        FindPSTs = Split(strFileList, ";")
    End If
End Function


Listing 9.1 [page 331]
======================

' Use this version to set the default profile
Call SetOABLastFirst(True, "")

' Use this version (and comment the other) to
' set a named profile.
' Call SetOABLastFirst(True, "profilename")

Sub SetOABLastFirst(blnLastFirst, strProfile)
    ' If blnLastFirst = True, set OAB order to
    '   File As (Last, First)
    ' If blnLastFirst = False, set OAB order to
    '   First Last
    ' strProfile can be a named profile or blank.
    '   If blank, set the order on the default profile.
    On Error Resume Next
    Const HKEY_CURRENT_USER = &H80000001
    strComputer = "."
    blnFoundKey = False
    
    If Not IsOutlookRunning Then
        Set objreg = GetObject _
          ("winmgmts:{impersonationLevel=impersonate}!\\" _
          & strComputer & "\root\default:StdRegProv")
        strKeyPath = "Software\Microsoft\Windows NT\" & _
                    "CurrentVersion\" & _
                    "Windows Messaging Subsystem\Profiles\"
        ' get string for service DLL file
        strServDLL = StringToHex4("contab.dll")
        ' get profile name
        If strProfile = "" Then
            objreg.GetStringValue HKEY_CURRENT_USER, _
                                  strKeyPath, _
                                  "DefaultProfile", _
                                  strProfile
        End If
        If strProfile <> "" Then
            strKeyPath = strKeyPath & strProfile
            objreg.EnumKey HKEY_CURRENT_USER, strKeyPath, _
                           arrProfileKeys
            For Each subkey In arrProfileKeys
               strSubkeyPath = strKeyPath & "\" & subkey
                ' 001f300a value contains
                ' name of the service DLL file
                objreg.GetBinaryValue HKEY_CURRENT_USER, _
                                      strSubkeyPath, _
                                      "001f300a", _
                                      arrKeyValue
                If Not IsNull(arrKeyValue) Then
                    For i = 0 To UBound(arrKeyValue)
                        ' build string from hex values
                        strhexkeyvalue = strhexkeyvalue & _
                                    HexByte(arrKeyValue(i))
                        
                    Next
                    ' compare with service neame
                    If InStr(strhexkeyvalue, _
                             strServDLL) = 1 Then
                        blnFoundKey = True
                        'we have the right key,
                        '  so change the value
                        If blnLastFirst Then
                            arrBinary = Array(1, 0)
                        Else
                            arrBinary = Array(0, 0)
                        End If
                        objreg.SetBinaryValue _
                            HKEY_CURRENT_USER, _
                            strSubkeyPath, _
                            "000b6602", arrBinary
                        Exit For
                    End If
                End If
            Next
            If blnFoundKey = False Then
                strMsg = "Could not find Outlook " & _
                         "Address Book in the " & _
                         strProfile & " mail profile."
                MsgBox strMsg, vbExclamation, _
                       "SetOABLastFirst"
            End If
        Else
            strMsg = "Please run Outlook once before " & _
                     "running this script. "
            MsgBox strMsg, vbExclamation, "SetOABLastFirst"
        End If
    Else
        strMsg = "Please shut down Outlook before running this script."
        MsgBox strMsg, vbExclamation, "SetOABLastFirst"
    End If
End Sub

Function IsOutlookRunning()
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\cimv2")
    strQuery = "Select * from Win32_Process Where " & _
               "Name = 'Outlook.exe'"
    Set colProcesses = objWMIService.ExecQuery(strQuery)
    For Each objProcess In colProcesses
        If UCase(objProcess.Name) = "OUTLOOK.EXE" Then
            IsOutlookRunning = True
        Else
            IsOutlookRunning = False
        End If
    Next
End Function

Function HexByte(b)
      HexByte = Right("0" & Hex(b), 2)
End Function

Public Function StringToHex4(Data)
    ' Input: normal text
    ' Output: four-character strings for each character,
    '         e.g. "3204" for lower-case Russian B,
    '        "6500" for ASCII e
    Dim strChar
    Dim strAll
    
    For i = 1 To Len(Data)
        ' get the four-character hex for each character
        strChar = Mid(Data, i, 1)
        strTemp = Right("00" & Hex(AscW(strChar)), 4)
        strAll = strAll & Right(strTemp, 2) & _
                 Left(strTemp, 2)
    Next
    StringToHex4 = strAll
End Function


Listing 9.2 [page 335]
======================

' Use this version to set all accounts
' in the default mail profile
' to use a previously created signature
Call SetDefaultSignature("Signature Name", "")

' Use this version (and comment the other) to
' modify a named profile.
'Call SetDefaultSignature _
'  ("Signature Name", "Profile Name")

Sub SetDefaultSignature(strSigName, strProfile)
    Const HKEY_CURRENT_USER = &H80000001
    strComputer = "."
    
    If Not IsOutlookRunning Then
        Set objreg = GetObject("winmgmts:" & _
          "{impersonationLevel=impersonate}!\\" & _
          strComputer & "\root\default:StdRegProv")
        strKeyPath = "Software\Microsoft\Windows NT\" & _
                     "CurrentVersion\Windows " & _
                     "Messaging Subsystem\Profiles\"
        ' get default profile name if none specified
        If strProfile = "" Then
            objreg.GetStringValue HKEY_CURRENT_USER, _
              strKeyPath, "DefaultProfile", strProfile
        End If
        ' build array from signature name
        myArray = StringToByteArray(strSigName, True)
        strKeyPath = strKeyPath & strProfile & _
                     "\9375CFF0413111d3B88A00104B2A6676"
        objreg.EnumKey HKEY_CURRENT_USER, strKeyPath, _
                       arrProfileKeys
        For Each subkey In arrProfileKeys
            strsubkeypath = strKeyPath & "\" & subkey
            'On Error Resume Next
            objreg.SetBinaryValue HKEY_CURRENT_USER, _
              strsubkeypath, "New Signature", myArray
            objreg.SetBinaryValue HKEY_CURRENT_USER, _
              strsubkeypath, "Reply-Forward Signature", myArray
        Next
    Else
        strMsg = "Please shut down Outlook before " & _
                 "running this script."
        MsgBox strMsg, vbExclamation, "SetDefaultSignature"
    End If
End Sub

Function IsOutlookRunning()
    strComputer = "."
    strQuery = "Select * from Win32_Process " & _
               "Where Name = 'Outlook.exe'"
    Set objWMIService = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" _
        & strComputer & "\root\cimv2")
    Set colProcesses = objWMIService.ExecQuery(strQuery)
    For Each objProcess In colProcesses
        If UCase(objProcess.Name) = "OUTLOOK.EXE" Then
            IsOutlookRunning = True
        Else
            IsOutlookRunning = False
        End If
    Next
End Function

Public Function StringToByteArray _
                 (Data, NeedNullTerminator)
    Dim strAll
    strAll = StringToHex4(Data)
    If NeedNullTerminator Then
        strAll = strAll & "0000"
    End If
    intLen = Len(strAll) \ 2
    ReDim arr(intLen - 1)
    For i = 1 To Len(strAll) \ 2
        arr(i - 1) = CByte _
                   ("&H" & Mid(strAll, (2 * i) - 1, 2))
    Next
    StringToByteArray = arr
End Function

Public Function StringToHex4(Data)
    ' Input: normal text
    ' Output: four-character string for each character,
    '         e.g. "3204" for lower-case Russian B,
    '        "6500" for ASCII e
    ' Output: correct characters
    ' needs to reverse order of bytes from 0432
    Dim strAll
    For i = 1 To Len(Data)
        ' get the four-character hex for each character
        strChar = Mid(Data, i, 1)
        strTemp = Right("00" & Hex(AscW(strChar)), 4)
        strAll = strAll & Right(strTemp, 2) & Left(strTemp, 2)
    Next
    StringToHex4 = strAll
End Function


Listing 9.3 [page 337]
======================

' name of user profile to modify
' leave blank to modify default profile
strProfileName = "Flavius"

' alias of mailbox to add to the profile
strMailbox = "helpdesk"

' constants for MAPI properties
Const PR_STORE_PROVIDERS = &H3D000102
Const PR_PROVIDER_UID = &H300C0102
Const PR_DISPLAY_NAME = &H3001001E
Const PR_PROFILE_MAILBOX = &H660B001E
Const PR_PROFILE_SERVER = &H660C001E
Const PR_PROFILE_SERVER_DN = &H6614001E
Const PR_EMAIL_ADDRESS = &H3003001E


'get PR_PROFILE_SERVER and PR_PROFILE_SERVER_DN
'It is assumed that the mailbox to add is on the
'same server as the current user's mailbox
MAPI_STORE_PROVIDER = 33
On Error Resume Next
Set profiles = CreateObject("ProfMan.Profiles")
On Error GoTo 0
If Err = 0 Then
    If strProfileName = "" Then
        Set profile = profiles.DefaultProfile
    Else
        For i = 1 To profiles.Count
            Set profile = profiles.Item(i)
            If profile.Name = strProfileName Then
                Exit For
            End If
        Next
    End If
    If profile.Name = strProfileName Then
        Set Services = profile.Services
        For i = 1 To Services.Count
            Set Service = Services.Item(i)
            If Service.ServiceName = "MSEMS" Then
                Set Providers = Service.Providers
                For j = 1 To Providers.Count
                    Set Provider = Providers.Item(j)
                    If Provider.ResourceType = _
                       MAPI_STORE_PROVIDER Then
                        Set ProfSect = Provider.ProfSect  
                        strProfileServer = _
                          ProfSect.Item(PR_PROFILE_SERVER)
                        strProfileServerDN = _
                          ProfSect.Item(PR_PROFILE_SERVER_DN)
                    End If
                Next
            End If
        Next
        
        ' use CDO 1.21 to obtain the AddressEntry for the
        ' desired mailbox alias
        Set myCDOSession = CreateObject("MAPI.Session")
        myCDOSession.Logon strProfileName, "", False, True
        ' Next statement is subject to Outlook security
        ' prompts; the user must click Yes for the script to
        ' complete.
        Set cdoAddrEntry = GetAddressEntry _
                             (strMailbox, myCDOSession)
        If Not cdoAddrEntry Is Nothing Then
            ' add the mailbox to the profile
            Call AddMailBox(strProfileName, _
                   "Mailbox - " & _
                     cdoAddrEntry.Fields(PR_DISPLAY_NAME).Value, _
                   cdoAddrEntry.Fields(PR_EMAIL_ADDRESS).Value, _
                   strProfileServer, _
                   strProfileServerDN)
        End If
        myCDOSession.Logoff
    Else
        strMessage = "No profile named " & strProfileName & _
                     " was available."
        MsgBox strMessage, vbExclamation, "Script halted"
    End If
Else
    strMessage = "Please install the Profman library " & _
                 "before running the AddMailbox script."
    MsgBox strMessage, vbExclamation, "Script halted"
End If


Sub AddMailBox(strProfile, strDisplayName, _
               strMailboxDN, strServer, strServerDN)
    Set profiles = CreateObject("ProfMan.Profiles")
    If strProfile = "" Then
        Set profile = profiles.DefaultProfile
    Else
        For i = 1 To profiles.Count
            Set profile = profiles.Item(i)
            If profile.Name = strProfile Then
                Exit For
            End If
        Next
    End If
    If profile.Name = strProfile Then
        'find the Exchange service
        Set Services = profile.Services
        For i = 1 To Services.Count
            Set Service = Services.Item(i)
            If Service.ServiceName = "MSEMS" Then
                'Add "EMSDelegate" provider
                Set Properties = _
                  CreateObject("ProfMan.PropertyBag")
                Properties.Add _
                  PR_DISPLAY_NAME, strDisplayName
                Properties.Add _
                  PR_PROFILE_MAILBOX, strMailboxDN
                Properties.Add _
                  PR_PROFILE_SERVER, strServer
                Properties.Add _
                  PR_PROFILE_SERVER_DN, strServerDN
                Set Provider = _
                  Service.Providers.Add _
                    ("EMSDelegate", Properties)
                ' update the old value of PR_STORE_PROVIDERS
                ' so that Outlook will show the mailbox in
                ' the list in Tools | E-mail Accounts
                Set GlobalProfSect = profile.GlobalProfSect
                OldProviders = _
                  GlobalProfSect.Item(PR_STORE_PROVIDERS)
                strUID = Provider.UID
                GlobalProfSect.Item(PR_STORE_PROVIDERS) = _
                  OldProviders & strUID
            End If
        Next
    Else
        strMessage = "No profile named " & strProfileName & _
                     " was available."
        MsgBox strMessage, vbExclamation, "Script halted"
    End If
End Sub

Function GetAddressEntry(strAlias, mySession)
    Dim objMsg
    Dim objRecip
    Set objMsg = mySession.Outbox.Messages.Add
    Set objRecip = objMsg.Recipients.Add("=" & strAlias)
    objRecip.Resolve True
    If Left(objRecip.Address, 3) = "EX:" Then
        Set GetAddressEntry = objRecip.AddressEntry
    Else
        Set GetAddressEntry = Nothing
    End If
End Function


Listing 9.4 [page 342]
======================

' Set the 10-element list of color labels here,
'   separating each pair with a semi-colon.
' To use the default label for a color,
'   leave the element blank
' To convert non-ASCII characters, use
'   ChrW(CLng(<hex value of character>)
strLabelList = "red;blue;green;;orange;aqua;;" & _
               "purple;;" & _
               ChrW(CLng(&H436)) & ChrW(CLng(&H451)) & _
               ChrW(CLng(&H43B)) & ChrW(CLng(&H442)) & _
               ChrW(CLng(&H44B)) & ChrW(CLng(&H439))

' To reset color label list to localized defaults,
'   comment out the strLabelList statement above
'   and use this one instead
'strLabelList = ";;;;;;;;;"

' Use this version to modify the labels in the
' Calendar folder in the default mail profile
'Call SetDefaultCalLabels(strLabelList, "")

' Use this version (and comment the other) to
' modify modify the labels in a particuilar profile
Call SetDefaultCalLabels(strLabelList, "Flavius")


Sub SetDefaultCalLabels(strLabelNames, strProfile)
    Const CdoDefaultFolderCalendar = 0
    On Error Resume Next
    If strProfile = "" Then
        strProfile = GetDefaultMailProfileName()
    End If
    ' start CDO session
    Set cdoMySession = CreateObject("MAPI.Session")
    cdoMySession.Logon strProfile, "", False, True
    Set cdocalendar = cdoMySession.GetDefaultFolder _
                      (CdoDefaultFolderCalendar)
    res = SetCalendarLabels(cdocalendar, strLabelNames)
    cdoMySession.Logoff
    Set cdoMySession = Nothing
End Sub

Function SetCalendarLabels(cdoFolder, strLabels)
    ' return True if successful, False if not
    On Error Resume Next
    ' build string for properties
    ' need 10 labels, can be blank between ;
    strAllLabels = "0000"
    arr = Split(strLabels, ";")
    For j = 0 To 9
        strLabelName = arr(j)
        strAllLabels = strAllLabels & _
                       StringToHex4(strLabelName) & "0000"
    Next
    Set cdoMyField = cdoFolder.Fields(&H36DC0102)
    If cdoMyField Is Nothing Then
        Set cdoMyField = cdoFolder.Fields.Add _
                       (&H36DC0102, strAllLabels)
    Else
        cdoMyField.Value = strAllLabels
    End If
    cdoFolder.Update True, True
    
    If Err = 0 Then
        SetCalendarLabels = True
    Else
        SetCalendarLabels = False
    End If
End Function

Function StringToHex4(Data)
    ' Input: normal text
    ' Output: four-character string for each character,
    '         e.g. "3204" for lower-case Russian B,
    '        "6500" for ASCII e
    ' Output: correct characters
    ' needs to reverse order of bytes from 0432
    Dim strAll
    For i = 1 To Len(Data)
        ' get the four-character hex for each character
        strChar = Mid(Data, i, 1)
        strTemp = Right("00" & Hex(AscW(strChar)), 4)
        strAll = strAll & _
                 Right(strTemp, 2) & Left(strTemp, 2)
    Next
    StringToHex4 = strAll
End Function

Function GetDefaultMailProfileName()
    Const HKEY_CURRENT_USER = &H80000001
    strComputer = "."
    Set objreg = GetObject("winmgmts:" & _
          "{impersonationLevel=impersonate}!\\" & _
          strComputer & "\root\default:StdRegProv")
    strKeyPath = "Software\Microsoft\Windows NT\" & _
                 "CurrentVersion\Windows " & _
                 "Messaging Subsystem\Profiles\"
    objreg.GetStringValue HKEY_CURRENT_USER, _
          strKeyPath, "DefaultProfile", strProfile
    GetDefaultMailProfileName = strProfile
End Function


Listing 9.5 [page 345]
======================

' name of the domain you want to filter
' with a search folder
strDomain = "microsoft.com"

Call MakeDomainSearchFolder(strDomain, True)

Sub MakeDomainSearchFolder(SearchDomain, SearchSubfolders)
    schemaFromName = "urn:schemas:httpmail:fromname"
    schemaFromAddress = _
     "http://schemas.microsoft.com/mapi/proptag/0x0065001f"
    
    SearchDomain = "%" & SearchDomain & "%"
    strSearch = Quote(schemaFromAddress) & _
                " LIKE " & SQLQuote("%microsoft.com%")
    Set olApp = CreateObject("Outlook.Application")
    Set olSearch = olApp.AdvancedSearch _
                   ("Inbox", strSearch, SearchSubfolders)
    olSearch.Stop
    Set olFolder = _
      olSearch.Save("Messages from " & SearchDomain)
    Set olFolder = Nothing 
    Set olSearch = Nothing
    Set olApp = Nothing
End Sub

Function Quote(Data)
    Quote = Chr(34) & Data & Chr(34)
End Function

Function SQLQuote(Data)
    SQLQuote = Chr(39) & Data & Chr(39)
End Function


Listing 9.6 [page 349]
======================

' path to public folder; should be similar to
'   "Public Folders\All Public Folders\Company\Sales"
strFolder = "Public Folders\All Public Folders\" & _
            "Human Resources\Company Events"
Call AddFolderToFavorites(strFolder, True)

Sub AddFolderToFavorites(strPath, AddToAddressBook)
    Const olContactItem = 2
    Set myFolder = GetFolder(strPath)
    If Not myFolder Is Nothing Then
        myFolder.AddToPFFavorites
        ' if contacts folder,
        ' optionally add new Favorite to OAB
        If myFolder.DefaultItemType = olContactItem Then
            If AddToAddressBook = True Then
                strFavFolder = _
                  "Public Folders\Favorites\" & _
                  myFolder.Name
                Set myFavFolder = GetFolder(strFavFolder)
                If Not myFavFolder Is Nothing Then
                    myFavFolder.ShowAsOutlookAB = True
                End If
            End If
        End If
    End If
    Set myFolder = Nothing
End Sub

Public Function GetFolder(strFolderPath)
  On Error Resume Next
  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders = Split(strFolderPath, "\")
  Set objApp = CreateObject("Outlook.Application")
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For I = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(I))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If
  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function


Listing 9.7 [page 350]
======================

Dim cdoMyCalendar 
Const CdoDefaultFolderCalendar = 0
'On Error Resume Next
strProfileName = GetDefaultMailProfileName()
' start CDO session
Set cdoMySession = CreateObject("MAPI.Session")
cdoMySession.Logon strProfileName, "", False, True
Set cdoMyCalendar = cdoMySession.GetDefaultFolder _
                  (CdoDefaultFolderCalendar)
If Not cdoMyCalendar Is Nothing Then
    ' make sure Calendar is an Exchange folder
    strStoreID = cdoMyCalendar.StoreID
    Set cdoMyStore = _
      cdoMySession.GetInfoStore(strStoreID)
    If cdoMyStore.ProviderName = _
      "Microsoft Exchange Server" Then
        Call SetDefaultACLReviewer(cdoMyCalendar)
    End If
End If
Set cdoMyCalendar = Nothing
cdoMySession.Logoff
Set cdoMySession = Nothing

Sub SetDefaultACLReviewer(thisFolder)
    Const ROLE_REVIEWER = &H401
    ' get ACL & bind to folder
    Set objCalACL = CreateObject("MSExchange.ACLObject")
    objCalACL.CDOItem = thisFolder
    Set colACEs = objCalACL.ACEs
    ' get the Default user's Access Control Entry
    Set objACE = colACEs.Item("ID_ACL_DEFAULT")
    If objACE Is Nothing Then
        Set objACE = CreateObject("MSExchange.ACE")
        objACE.ID = "ID_ACL_DEFAULT"
    End If
    ' set ReadItems and update ACL
    objACE.Rights = ROLE_REVIEWER
    objCalACL.Update
End Sub

Function GetDefaultMailProfileName()
    Const HKEY_CURRENT_USER = &H80000001
    strComputer = "."
    Set objreg = GetObject("winmgmts:" & _
          "{impersonationLevel=impersonate}!\\" & _
          strComputer & "\root\default:StdRegProv")
    strKeyPath = "Software\Microsoft\Windows NT\" & _
                 "CurrentVersion\Windows " & _
                 "Messaging Subsystem\Profiles\"
    objreg.GetStringValue HKEY_CURRENT_USER, _
          strKeyPath, "DefaultProfile", strProfile
    GetDefaultMailProfileName = strProfile
End Function