ProfMan examples

Common profile-management scripts. For the sake of simplicity, variables are not explicitly declared.

Enumerate and print the names of all services in all profiles

'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


'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


'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


'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, make it default, add an Exchange server to it, silently configure


'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

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 for a given profile (if AutoArchive is configured)

'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 legacy Outlook 2010/2013 profile that uses RPC-over-HTTP to connect to a Microsoft 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

 

Create and configure an Outlook 2016 profile that uses MAPI-over-HTTP or legacy RPC-over-HTTP to connect to a Microsoft 365 mailbox


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