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)
• Create and configure a new profile that uses ROH (RPC-over-HTTP) to connect to an Office 365 mailbox for Outlook 2010/2013.
• Create and configure a new profile that uses RPC-over-HTTP or MAPI-over-HTTP to connect to an Office 365 mailbox for Outlook 2016.
  

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

Create and configure a new profile that uses ROH (RPC-over-HTTP) to connect to an Office 365 mailbox.

ProfileName = "ROH 1"

strProfileUserName = "test@AdvancedMessagingSystemsLLC.onmicrosoft.com"

'the data below must be retrieved from the autodiscover XML. The comments indicate the XML element names
strProxyPrincipalName = "msstd:outlook.com" ' EXPR\CertPrincipalName
strSSL = "On" ' EXPR\SSL
strAuthPackage = "Basic" ' 'EXPR\AuthPackage - Basic or Ntlm
strProxyServerName = "outlook.office365.com" ' EXPR\Server
strProfileServerName = "74a4d8f2-178a-4fa0-9735-61e9bb0f51d9@advancedmessagingsystemsllc.onmicrosoft.com" 'proxy server from EXCH\Server
strProfileAuthPackage = "Anonymous" 'EXCH\AuthPackage
strServerDN = "/o=ExchangeLabs/ou=Exchange Administrative Group (FYDIBOHF23SPDLT)/cn=Configuration/cn=Servers/cn=74a4d8f2-178a-4fa0-9735-61e9bb0f51d9@advancedmessagingsystemsllc.onmicrosoft.com" 'EXCH\ServerDN

PR_PROFILE_UNRESOLVED_NAME_W = &H6607001F
PR_PROFILE_UNRESOLVED_SERVER_W = &H6608001F
PR_PROFILE_AUTH_PACKAGE = &H66190003
PR_ROH_PROXY_AUTH_SCHEME = &H66270003
PR_ROH_FLAGS = &H66230003
PR_ROH_PROXY_SERVER_W = &H6622001F

PR_ROH_PROXY_PRINCIPAL_NAME_W = &H6625001F

ROHAUTH_BASIC = 1
ROHAUTH_NTLM = 2
RPC_C_AUTHN_NONE = 0
RPC_C_AUTHN_GSS_NEGOTIATE = 9
RPC_C_HTTP_AUTHN_SCHEME_NTLM = 2
RPC_C_HTTP_AUTHN_SCHEME_BASIC = 1
ROHFLAGS_USE_ROH = 1
ROHFLAGS_SSL_ONLY = 2
ROHFLAGS_MUTUAL_AUTH = 4
ROHFLAGS_HTTP_FIRST_ON_FAST = 8
ROHFLAGS_HTTP_FIRST_ON_SLOW = 32

set Profiles=CreateObject("ProfMan.Profiles")
set Profile = Profiles.Add(ProfileName, false, false)
'Add Exchange service
set ExchService = Profile.Services.Add("MSEMS", "Microsoft Exchange", false)
set GlobalProfSect = Profile.GlobalProfSect

If strAuthPackage = "Ntlm" Then
    intAuthScheme = ROHAUTH_NTLM
Else
    intAuthScheme = ROHAUTH_BASIC
End If

'cache username/domain in the global section
'this way Outlook will know what to put in the credentials prompt dialog
GlobalProfSect.Item(&H3D16001F) = strProfileUserName
GlobalProfSect.Item(&H3D17001F)= "" 'Domain name in case of NTLM credentials domain\user

GlobalProfSect.Item(PR_PROFILE_UNRESOLVED_SERVER_W) = strProfileServerName
GlobalProfSect.Item(PR_PROFILE_UNRESOLVED_NAME_W) = strProfileUserName

GlobalProfSect.Item(PR_ROH_PROXY_PRINCIPAL_NAME_W) = strProxyPrincipalName

if strProfileAuthPackage = "Anonymous" Then
    GlobalProfSect.Item(PR_PROFILE_AUTH_PACKAGE)= RPC_C_AUTHN_NONE
Else
    GlobalProfSect.Item(PR_PROFILE_AUTH_PACKAGE)= RPC_C_AUTHN_GSS_NEGOTIATE
End If

dwRohFlags = ROHFLAGS_USE_ROH or ROHFLAGS_HTTP_FIRST_ON_FAST or ROHFLAGS_HTTP_FIRST_ON_SLOW
if strSsl = "On" Then
    dwRohFlags = dwRohFlags or ROHFLAGS_SSL_ONLY
end If

if strAuthPackage = "Ntlm" Then
    GlobalProfSect.Item(PR_ROH_PROXY_AUTH_SCHEME) = RPC_C_HTTP_AUTHN_SCHEME_NTLM
    dwRohFlags = dwRohFlags or ROHFLAGS_MUTUAL_AUTH or ROHFLAGS_SSL_ONLY
Else
    GlobalProfSect.Item(PR_ROH_PROXY_AUTH_SCHEME) = RPC_C_HTTP_AUTHN_SCHEME_BASIC
End If

GlobalProfSect.Item(PR_ROH_FLAGS) = dwRohFlags

GlobalProfSect.Item(PR_ROH_PROXY_SERVER_W) = strProxyServerName

strUserEmailAdddress = "user@domain.demo"
strDisplayName = "Joe The User"
PROFILE_NAME = "Outlook2016Profile"

PR_DISPLAY_NAME_W = &H3001001F
PR_PROFILE_USER_SMTP_EMAIL_ADDRESS_W = &H6641001F
PR_EMSMDB_SECTION_UID = &H3D150102
PR_STORE_PROVIDERS = &H3D000102

' ---------- create profile

set Profiles = CreateObject("ProfMan.Profiles")
set NewProfile = Profiles.Add(PROFILE_NAME, false, false)

NewProfile.Default = True

' ---------- add MSEMS service

set ExchService = NewProfile.Services.Add("MSEMS","Microsoft Exchange", false)

' ---------- get GUID in MSEMS service

vProfileGuid = ExchService.ProfSect.Item(PR_EMSMDB_SECTION_UID)

' ---------- get matching provider in MSEMS service

for k = 1 to ExchService.Providers.Count

  set ExProvider = ExchService.Providers.Item(k)
  ProviderUid = ExProvider.UID

  if ProviderUid = vProfileGuid then
 
    ' ---------- get ProfSect in provider
    set ProviderProfSect = ExProvider.ProfSect

    ' ---------- get email address to provider ProfSect
    ProviderProfSect.Item(PR_PROFILE_USER_SMTP_EMAIL_ADDRESS_W) = strUserEmailAdddress

    ' ---------- get Store Provider Uid
    ProviderStoreUid = ExchService.ProfSect.Item(PR_STORE_PROVIDERS)
  end if
next

for k = 1 to ExchService.Providers.Count

  set ExProvider = ExchService.Providers.Item(k)
  ProviderUid = ExProvider.UID

  if ProviderUid = ProviderStoreUid then
 
    ' ---------- get store ProfSect in provider
    set StoreProviderProfSect = ExProvider.ProfSect

    ' ---------- get email address to store provider ProfSect
    StoreProviderProfSect.Item(PR_PROFILE_USER_SMTP_EMAIL_ADDRESS_W) = strUserEmailAdddress
  end if

next