Profiles

Distributable version of Redemption comes with a bonus library - Profman.

Normally MAPI profiles can only be manipulated using Extended MAPI in C/C++/Delphi. Profman library allows to manipulate MAPI profiles from any language, including VB and VB script. Note that Outlook 98/2000 installed in the Internet Only Mode (IMO) does not have profiles.

Installing Profman: Profman.dll is a regular self-registering COM dll; to register it either run regsvr32.exe Profman.dll or mark the dll as self-registering in your favorite installer.

See examples below. To learn more about the Extended MAPI profiles, download OutlookSpy from this site or ProfMan sample from MSDN

Profman Object Model:


Object Name	Property/Method	Description

Profiles	Count property	The number of profiles
	Item(Index) collection	Collection of all profiles, returns Profile object
	Add(strName, bAddDefaultServices, bShowDialog, wndParentWindow)	Create a new profile with a given name
	Delete(Index)	Delete a profile
	DefaultProfile	Default profile. See Profile object below

Profile	Name property	Name of the profile. Read/Write
	Default property	Boolean, Read/Write
	Delete method	Delete the profile
	Services collection	See Services object below
	Copy(NewProfileName)	Copy the profile to a new profile with the given name

Services	Count property	Number of services in the profile
	Item(Index) collection	Returns Service object
	Add(strServiceName, strDisplayName, bShowUI, wndParentWindow)	Add new service to a profile
	Delete(Index)	Delete a service from a profile

Service	ServiceName property	The name of the service. Read only
	ResourceFlags property	Resource flags, integer, read only. See PR_RESOURCE_FLAGS on MSDN for a description of the possible values
	DllName property	The name of the dll containing the service
	ServiceEntryName property	The name of the function from the service dll which contains its entry point
	ServiceSupportFiles property.	An array of strings with the names of all the files required for the service.
	Configure(ShowUI, wndParentWindow, objProperties)	Configures the service. ShowUI must either be 0 (never), 1 (allowed if necessary) or 2 (always). wndParentWindow is the handle of a window which serves as a parent of a dialog the service might show objProperties - Profman.PropertyBag object. A collection of properties used to configure the service. See PropertyBag object below and the examples.
	DisplayName property	Display name of the service. Read/Write
	Providers collection	Service providers collection. See Providers object below
	ProfSect property	Provides access to the invividual service properties. See ProfSect object below

Providers	Count property	Number of providers in a service
	Item(Index) collection	Returns Provider object
	Add(strProviderName, objProperties)	Adds a new provider with a given name and properties given by objProperties (see PropertyBag below and an example)

Provider	DisplayName property	Display name of the provider. Read only
	ProviderDisplay property	Corresponds to the PR_PROVIDER_DISPLAY Extended MAPI property
	ProviderDllName property	The name of the dll containing the provider. Corresponds to the PR_PROVIDER_DLL_NAME Extended MAPI property.
	ResourceFlags property	Resource flags of the provider. See PR_RESOURCE_FLAGS property on MSDN for the possible values
	ResourceType property	Corresponds to the PR_RESOURCE_TYPE Extended MAPI property.
	ServiceName property	Corresponds to the PR_SERVICE_NAME Extended MAPI property.
	ProfSect property	Provides access to the invividual provider properties. See ProfSect object below
	UID property	Provider UID

ProfSect	Item(PropertyTag)	Provides access to the individual service or provider properties, e.g. ProfSect.Item(&H3001001E) to get the PR_DISPLAY_NAME property

PropertyBag This object is separately created and used to pass a collection of properties to the Service.Configure() and Providers.Add() methods. See examples below.	Add(intPropTag, varValue)	Adds a new property to the bag. See examples below

Examples. For the sake of simplicity no variables are dimmed.

Enumerate and print the names of all services in all profiles
Print the path to all the PST files in all profiles
Enumerate and print the names of all services and providers in all profiles
Create (or reuse) a profile and add a PST file if it is not already there
Create new profile, make it default, add an Exchange server to it, silently configure
Add an extra Exchange mailbox to a given profile
Display the path to the archive PST file for a given profile (if AutoArchive is configured)

'Enumerate and print the names of all services in all profiles
set Profiles=CreateObject("ProfMan.Profiles")
for i = 1 to Profiles.Count
set Profile = Profiles.Item(i)
set Services = Profile.Services
Debug.Print "------ " & Profile.Name & " ------"
for j = 1 to Services.Count
Debug.Print Services.Item(j).ServiceName
next
next

'Print the path to all the PST files in all profiles
PR_PST_PATH = &H6700001E
set Profiles=CreateObject("ProfMan.Profiles")
for i = 1 to Profiles.Count
set Profile = Profiles.Item(i)
set Services = Profile.Services
Debug.Print "------ Profile: " & Profile.Name & " ------"
for j = 1 to Services.Count
    set Service = Services.Item(j)
    If (Service.ServiceName = "MSPST MS") or (Service.ServiceName = "MSUPST MS") Then
      'there should be only one provider for this service
      'but we should really loop through all the providers
      Debug.Print Service.Providers.Item(1).ProfSect.Item(PR_PST_PATH)
    End If
next
next

'Enumerate and print the names of all services and providers in all profiles
set Profiles=CreateObject("ProfMan.Profiles")
for i = 1 to Profiles.Count
set Profile = Profiles.Item(i)
set Services = Profile.Services
Debug.Print "------ " & Profile.Name
for j = 1 to Services.Count
    set Service = Services.Item(j)
    Debug.Print " ------ " & Service.ServiceName
    for k = 1 to Service.Providers.Count
      set Provider = Service.Providers.Item(k)
      Debug.Print " ------ " & Provider.DisplayName
    next
next
next

'Create (or reuse) a profile and add a PST file if it is not already there
PR_PST_PATH = &H6700001E
PR_DISPLAY_NAME = &H3001001E
ProfileName = "Test PST Profile"
PSTPath = "c:\MyNewPST.pst"
set Profiles=CreateObject("ProfMan.Profiles")
on Error Resume Next
Err.Clear
set Profiles=CreateObject("ProfMan.Profiles")
set NewProfile = Profiles.Item(ProfileName)
if Err.Number <> 0 Then
set NewProfile = Profiles.Add(ProfileName, false, false)
End If
set Services = NewProfile.Services
bPSTFound = false
for i = 1 to Services.Count
set Service = Services.Item(i)
for j = 1 to Service.Providers.Count
    set Provider = Service.Providers.Item(j)
    if Provider.ProfSect.Item(PR_PST_PATH) = PSTPath Then
      bPSTFound = true
    End If
next
next
If not bPSTFound Then
set PstService = NewProfile.Services.Add("MSPST MS", "Personal Folders", false)
set Properties = CreateObject("ProfMan.PropertyBag")
Properties.Add PR_PST_PATH, PSTPath
Properties.Add PR_DISPLAY_NAME, "The greatest PST file ever"
PstService.Configure 0, , Properties
End If

'Create new profile, add an Exchange server to it, configure
'and make it default
ProfileName = "Exchange Server Profile"
PR_PROFILE_UNRESOLVED_NAME = &H6607001E
PR_PROFILE_UNRESOLVED_SERVER = &H6608001E
On Error Resume Next
set Profiles=CreateObject("ProfMan.Profiles")
'does that profile already exist?
set NewProfile = Profiles.Item(ProfileName)
if Err.Number <> 0 Then
'No, we must create the profile. Do so without adding the default
'services and without showing any UI
set NewProfile = Profiles.Add(ProfileName, false, false)
End If
'make the profile default
NewProfile.Default = true
'Add Exchange service
set ExchService = NewProfile.Services.Add("MSEMS", "Microsoft Exchange", false)
'create "ProfMan.PropertyBag" object to be used later
'in a call to ExchService.Configure
set Properties = CreateObject("ProfMan.PropertyBag")
'add the properties required to silently
'configure the Exchange provider
Properties.Add PR_PROFILE_UNRESOLVED_NAME, "username" 'real value must used, e.g. "dmitry"
Properties.Add PR_PROFILE_UNRESOLVED_SERVER, "AddressOfTheServer" 'real value must used, e.g. "MyMailServer"
'Silently configure the Exchange provider
'ShowUI: 0 - never, 1 - if necessary, 2 - always
'Note: domain logon dialog will always be shown
'if you are not currently logged in to the same domain
ExchService.Configure 0, , Properties

add an extra Exchange mailbox to a given profile. This sample uses CDO to retrieve the properties of the mailbox to be added
'see Q171636 for details

'todo: replace the name of the profile!!!
strProfileName = "Dmitry Streblechenko"

PR_STORE_PROVIDERS = &H3D000102
PR_PROVIDER_UID = &H300C0102
PR_DISPLAY_NAME = &H3001001E
PR_PROFILE_MAILBOX = &H660B001E
PR_PROFILE_SERVER = &H660C001E
PR_PROFILE_SERVER_DN = &H6614001E
PR_EMAIL_ADDRESS = &H3003001E

Sub AddMailBox(strProfile, strDisplayName, strMailboxDN, strServer, strServerDN)
set Profiles=CreateObject("ProfMan.Profiles")
if strProfile = "" Then
    set Profile = Profiles.DefaultProfile
Else
    set Profile = Profiles.Item(strProfile)
   End If
'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 | Services
      set GlobalProfSect = Profile.GlobalProfSect
      OldProviders = GlobalProfSect.Item(PR_STORE_PROVIDERS)
      strUID = Provider.UID
      GlobalProfSect.Item(PR_STORE_PROVIDERS) = OldProviders & strUID
    End If
Next
End Sub

'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
set Profiles=CreateObject("ProfMan.Profiles")
set Profile = Profiles.Item(strProfileName)
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

'Add the first GAL entry's mailbox to the default profile
set AddrEntry = CDOSession.AddressLists.Item("Global Address List").AddressEntries.Item(1)
AddMailBox strProfileName, _
                    "Mailbox - " & AddrEntry.Fields(PR_DISPLAY_NAME).Value, _
                    AddrEntry.Fields(PR_EMAIL_ADDRESS).Value, _
                    strProfileServer, _
                    strProfileServerDN

'display the path to the archive PST file (if available) for a given profile
'replace the profile name with the name of the actual profile
set Profiles=CreateObject("ProfMan.Profiles")
'set Profile = Profiles.DefaultProfile
set Profile = Profiles.Item("dimastr.com")
set ProfSect = Profile.OpenProfileSection("{00020D0A-0000-0000-C000-000000000046}")
MsgBox ProfSect.Item(&H0324001E)