Sub CreateTaskWithAccount()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim bcmRootFolder As Outlook.Folder
Dim olFolders As Outlook.Folders
Dim bcmAccountsFldr As Outlook.Folder
Dim bcmHistoryFolder As Outlook.Folder
Dim newAcct As Outlook.ContactItem
Dim newHistoryTaskItem As Outlook.JournalItem
Dim newTaskItem As Outlook.TaskItem
Dim userProp As Outlook.UserProperty
Dim str As String
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 newTaskItem = olApp.CreateItem(olTaskItem)
newTaskItem.Subject = "Prepare Agenda For Meeting"
newTaskItem.StartDate = "03/02/06"
newTaskItem.DueDate = "03/03/06"
newTaskItem.Save
Set newHistoryTaskItem = bcmHistoryFolder.Items.Add("IPM.Activity.BCM")
newHistoryTaskItem.Subject = newTaskItem.Subject
newHistoryTaskItem.Type = "Task"
newHistoryTaskItem.Start = newTaskItem.StartDate
newHistoryTaskItem.End = newTaskItem.DueDate
'The reason we are concatenating StartDate and DueDate and assigning them to the newHistoryTaskItem body is as follows:
'In case the Outlook Task gets deleted, this information is preserved in the body of the Business Activity
newHistoryTaskItem.Body = "StartDate: " & newTaskItem.StartDate & vbNewLine & "DueDate: " & newTaskItem.DueDate
If (newHistoryTaskItem.UserProperties("Parent Entity EntryID") Is Nothing) Then
Set userProp = newHistoryTaskItem.UserProperties.Add("Parent Entity EntryID", olText, False, False)
userProp.Value = newAcct.EntryID
End If
If (newHistoryTaskItem.UserProperties("LinkToOriginal") Is Nothing) Then
Set userProp = newHistoryTaskItem.UserProperties.Add("LinkToOriginal", olText, False, False)
userProp.Value = newTaskItem.EntryID
End If
newHistoryTaskItem.Save
Set newTaskItem = Nothing
Set newHistoryTaskItem = Nothing
Set newAcct = Nothing
Set bcmAccountsFldr = Nothing
Set bcmHistoryFolder = Nothing
Set bcmRootFolder = Nothing
Set olFolders = Nothing
Set objNS = Nothing
Set olApp = Nothing