Sub CreateMarketingCampaign()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolders As Outlook.Folders
Dim bcmRootFolder As Outlook.Folder
Dim bcmCampaignsFldr As Outlook.Folder
Dim newMarketingCampaign As Outlook.TaskItem
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 bcmCampaignsFldr = bcmRootFolder.Folders("Marketing Campaigns")
Set newMarketingCampaign = bcmCampaignsFldr.Items.Add("IPM.Task.BCM.Campaign")
newMarketingCampaign.Subject = "Sales Project with Wide World Importers"
If (newMarketingCampaign.UserProperties("Campaign Code") Is Nothing) Then
Set userProp = newMarketingCampaign.UserProperties.Add("Campaign Code", olText, False, False)
userProp.Value = "SP2"
End If
If (newMarketingCampaign.UserProperties("Campaign Type") Is Nothing) Then
Set userProp = newMarketingCampaign.UserProperties.Add("Campaign Type", olText, False, False)
userProp.Value = "Direct Mail Print"
End If
If (newMarketingCampaign.UserProperties("Budgeted Cost") Is Nothing) Then
Set userProp = newMarketingCampaign.UserProperties.Add("Budgeted Cost", olCurrency, False, False)
userProp.Value = 243456
End If
If (newMarketingCampaign.UserProperties("Delivery Method") Is Nothing) Then
Set userProp = newMarketingCampaign.UserProperties.Add("Delivery Method", olText, False, False)
userProp.Value = "Word Mail Merge"
End If
If (newMarketingCampaign.UserProperties("End Time") Is Nothing) Then
Set userProp = newMarketingCampaign.UserProperties.Add("End Time", olDateTime, False, False)
userProp.Value = "3/10/2006"
End If
If (newMarketingCampaign.UserProperties("Start Time") Is Nothing) Then
Set userProp = newMarketingCampaign.UserProperties.Add("Start Time", olDateTime, False, False)
userProp.Value = "3/9/2006"
End If
newMarketingCampaign.Save
Set newMarketingCampaign = Nothing
Set bcmCampaignsFldr = Nothing
Set bcmRootFolder = Nothing
Set olFolders = Nothing
Set objNS = Nothing
Set olApp = Nothing
End Sub