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
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)