Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolders As Outlook.Folders
Dim bcmRootFolder As Outlook.Folder
Dim bcmAccountsFldr As Outlook.Folder
Dim bcmHistoryFolder As Outlook.Folder
Dim newAcct As Outlook.ContactItem
Dim newPhoneLog As Outlook.JournalItem
Dim userProp As Outlook.UserProperty
Set olApp = CreateObject("Outlook.Application")
Set objNS = olApp.GetNamespace("MAPI")
Set olFolders = objNS.Session.Folders
Set bcmRootFolder = olFolders("Business Contact Manager")
Set bcmAccountsFldr = bcmRootFolder.Folders("Accounts")
Set bcmHistoryFolder = bcmRootFolder.Folders("Communication History")
Set newAcct = bcmAccountsFldr.Items.Add("IPM.Contact.BCM.Account")
newAcct.FullName = "Wide World Importers"
newAcct.FileAs = "Wide World Importers"
newAcct.Email1Address = "someone@example.com"
newAcct.Save
Set newPhoneLog = bcmHistoryFolder.Items.Add("IPM.Activity.BCM.PhoneLog")
newPhoneLog.Type = "Phone Log"
newPhoneLog.Subject = "Called the Account and settled down the Tax Issue and took the confirmation"
If (newPhoneLog.UserProperties("Parent Entity EntryID") Is Nothing) Then
Set userProp = newPhoneLog.UserProperties.Add("Parent Entity EntryID", olText, False, False)
userProp.Value = newAcct.EntryID
End If
newPhoneLog.Save
Set newPhoneLog = Nothing
Set newAcct = Nothing
Set bcmAccountsFldr = Nothing
Set bcmHistoryFolder = Nothing
Set bcmRootFolder = Nothing
Set olFolders = Nothing
Set objNS = Nothing
Set olApp = Nothing