Craig,
Thanks for this suggestion. We are currently working on a solution for this scenario. In the mean time, I've written a handy
Outlook toolbar button macro to simplify this process. Below are instructions to add the button to your Outlook toolbar and the
actual macro code. Be sure to modify the file paths for your e-mail and letter templates near the top of the macro code. Let me
know if you have any questions.
To create these buttons on your Outlook toolbar:
1.) Verify that your security settings will prompt you to run unsigned macros by selecting
"Tools | Trust Center..." from the main Outlook window.
Then click "Macro Security" and select "Warnings for all macros" and click "OK"
2.) Create a Macro from the main Outlook window by selecting "Tools | Macro | Macros..."
3.) Type "Email" as the Macro Name, then click "Create"
4.) The Visual Basic editing window will open. On the left-hand side is a project navigation pane.
Right-click on the top-level item named "Project1" and select "Project1 Properties..."
5.) Change "Project1" to "Business" and click "OK"
6.) In the main code area, you'll see "Sub Email()", followed by "End Sub".
Replace those two lines with the VBA code below, then click Save.
7.) Close the Visual Basic window to return to Outlook
8.) Right-click on the Outlook toolbar and click "Customize..."
9.) Select the "Commands" tab, select the "Macro" from the Categories list,
then drag "Business.Letter" and "Business.Email" to the standard Outlook toolbar
and click "Close" on the "Customize" dialog.
10.) Select a business contact or account, then click the "Business.Email" button.
'//////////////////////////////////////////////////////////////////////////
' Create a New Business E-mail for selected Business Contact(s) or Contacts
' linked to the selected Account(s), Opportunity(s), or Busines Project(s)
Sub Email()
' E-MAIL TEMPLATE: If you use an e-mail template, enter its path here
Const emailFilePath = "C:\E-mail Thank You.docx"
OpenCampaign True, emailFilePath
End Sub
' Create a New Business Letter for selected Business Contact(s) or Contacts
' linked to the selected Account(s), Opportunity(s), or Busines Project(s)
Sub Letter()
' LETTER TEMPLATE: If you use a letter template, enter its path here
Const letterFilePath = "C:\Thank You.docx"
OpenCampaign False, letterFilePath
End Sub
' Open a new Marketing Campaign with the appropriate settings
Sub OpenCampaign(Email As Boolean, contentFilePath As String)
' Get a reference to the MAPI namespace
Dim objNS As Outlook.NameSpace
Set objNS = Application.GetNamespace("MAPI")
' Make sure at least one item is selected
If Application.ActiveExplorer Is Nothing Then
MsgBox "Please select at least one item"
Exit Sub
End If
If Application.ActiveExplorer.selection Is Nothing Then
MsgBox "Please select at least one item"
Exit Sub
End If
' Get a reference to the currently selected item
Dim oItem As Object
Set oItem = Application.ActiveExplorer.selection(1)
If oItem Is Nothing Then
MsgBox "Please select at least one item"
Exit Sub
End If
' Get a reference to the currently selected Outlook folder
Dim currentFolder As Outlook.Folder
Set currentFolder = Application.ActiveExplorer.currentFolder
If currentFolder Is Nothing Then
MsgBox "Please select at least one item"
Exit Sub
End If
' Verify that this folder is located in the Business Contact
' Manager Outlook Store
If 1 <> InStr(1, currentFolder.FullFolderPath, _
"\\Business Contact Manager\", vbTextCompare) Then
MsgBox "Please select at least one Business Contact, Account, " & _
"Opportunity, or Business Project"
Exit Sub
End If
' Get the root BCM folder
Dim olFolders As Outlook.Folders
Dim bcmRootFolder As Outlook.Folder
Set olFolders = objNS.Session.Folders
If olFolders Is Nothing Then
MsgBox "Unable to get the list of Outlook Session folders"
Exit Sub
End If
Set bcmRootFolder = olFolders("Business Contact Manager")
' Get an XML recipient list
Dim strRecipientXML As String
strRecipientXML = _
GetRecipientXML(objNS, _
Application.ActiveExplorer.selection, _
bcmRootFolder)
If Trim(strRecipientXML) = "" Then
MsgBox "Please select at least one Business Contact, Account, " & _
"Opportunity, or Business Project"
Exit Sub
End If
' Locate the Marketing Campaigns folder
Dim marketingCampaignFolder As Outlook.Folder
Set marketingCampaignFolder = _
bcmRootFolder.Folders("Marketing Campaigns")
' Create a new Marketing Campaign
Const MarketingCampaignMessageClass = "IPM.Task.BCM.Campaign"
Dim newMarketingCampaign As Outlook.TaskItem
Set newMarketingCampaign = _
marketingCampaignFolder.Items.Add(MarketingCampaignMessageClass)
' Campaign Code
Dim campaignCode As Outlook.userProperty
Set campaignCode = newMarketingCampaign.ItemProperties("Campaign Code")
If campaignCode Is Nothing Then
Set campaignCode = _
newMarketingCampaign.ItemProperties.Add("Campaign Code", _
olText, False, False)
End If
campaignCode.value = CStr(Now())
' Campaign Type
Dim campaignType As Outlook.userProperty
Set campaignType = _
newMarketingCampaign.ItemProperties("Campaign Type")
If campaignType Is Nothing Then
Set campaignType = _
newMarketingCampaign.ItemProperties.Add("Campaign Type", _
olText, False, False)
End If
' Delivery Method
Dim deliveryMethod As Outlook.userProperty
Set deliveryMethod = _
newMarketingCampaign.ItemProperties("Delivery Method")
If deliveryMethod Is Nothing Then
Set deliveryMethod = _
newMarketingCampaign.ItemProperties.Add("Delivery Method", _
olText, False, False)
End If
' See if this is an e-mail or print letter
Dim title As String
If Email Then
title = "E-mail to "
campaignType.value = "E-mail"
deliveryMethod.value = "Word E-Mail Merge"
Else
title = "Letter to "
campaignType.value = "Direct Mail Print"
deliveryMethod.value = "Word Mail Merge"
End If
' Marketing Campaign Title
Select Case oItem.MessageClass
Case "IPM.Contact.BCM.Contact":
title = title & oItem.FullName
Case "IPM.Contact.BCM.Account":
title = title & oItem.FullName
Case "IPM.Task.BCM.Opportunity":
title = title & oItem.subject
Case "IPM.Task.BCM.Project"
title = title & oItem.subject
End Select
newMarketingCampaign.subject = title
' Content File
Dim contentFile As Outlook.userProperty
Set contentFile = newMarketingCampaign.ItemProperties("Content File")
If contentFile Is Nothing Then
Set contentFile = _
newMarketingCampaign.ItemProperties.Add("Content File", _
olText, False, False)
End If
contentFile.value = contentFilePath
' FormQuerySelection
Dim formQuerySelection As Outlook.userProperty
Set formQuerySelection = _
newMarketingCampaign.ItemProperties("FormQuerySelection")
If formQuerySelection Is Nothing Then
Set formQuerySelection = _
newMarketingCampaign.ItemProperties.Add("FormQuerySelection", _
olInteger, False, False)
End If
formQuerySelection.value = 9 ' Custom Query
' Recipient List XML
Dim recipientListXML As Outlook.userProperty
Set recipientListXML = _
newMarketingCampaign.ItemProperties("Recipient List XML")
If recipientListXML Is Nothing Then
Set recipientListXML = _
newMarketingCampaign.ItemProperties.Add("Recipient List XML", _
olText, False, False)
End If
' Set the Recipient List XML
recipientListXML.value = strRecipientXML
' Save the marketing campaign
newMarketingCampaign.Save
' Launch the new marketing campaign
newMarketingCampaign.Display (False)
Set recipientListXML = Nothing
Set formQuerySelection = Nothing
Set deliveryMethod = Nothing
Set contentFile = Nothing
Set campaignType = Nothing
Set campaignCode = Nothing
Set newMarketingCampaign = Nothing
Set marketingCampaignFolder = Nothing
Set bcmRootFolder = Nothing
Set olFolders = Nothing
Set oItem = Nothing
Set currentFolder = Nothing
Set objNS = Nothing
End Sub
' Returns an XML string that specifies the recipients
Function GetRecipientXML(objNS As Outlook.NameSpace, _
selectionList As Outlook.selection, _
bcmRootFolder As Outlook.Folder) As String
' Initialize the retun value to empty string
GetRecipientXML = ""
' Make sure we have a valid parameters
If objNS Is Nothing Or _
selectionList Is Nothing Or _
bcmRootFolder Is Nothing Then
Exit Function
End If
' Build the recipient XML
Dim strRecipientXML
strRecipientXML = "<ArrayOfCampaignRecipient>"
' Add all selected items to the recipient list
Dim oItem As Object
Dim astrContactEntryIDs() As String
ReDim Preserve astrContactEntryIDs(0)
Dim contactEntryID As Variant
Dim oParentEntryID As Object
Dim oParent As Object
For Each oItem In selectionList
If oItem Is Nothing Then
MsgBox "Warning: Item not found"
Else
' Only get the EntryID if this is a Business Contact, Account,
' Opportunity, or Business Project
Select Case oItem.MessageClass
' Business Contact
Case "IPM.Contact.BCM.Contact":
AddCampaignRecipient astrContactEntryIDs, oItem.EntryID
' Account
Case "IPM.Contact.BCM.Account":
AddCampaignRecipient astrContactEntryIDs, oItem.EntryID
' Add Business Contacts associated with this Account
AddContactEnryIdsFromAccount objNS, bcmRootFolder, _
CStr(oItem.EntryID), _
astrContactEntryIDs
' Opportunity
Case "IPM.Task.BCM.Opportunity":
' Get the parent item
Set oParentEntryID = _
oItem.UserProperties("Parent Entity EntryID")
If oParentEntryID Is Nothing Then
MsgBox ("This opportunity is not linked to a " & _
"Business Contact or Account")
Else
AddCampaignRecipient astrContactEntryIDs, _
oParentEntryID.value
' Add Business Contacts associated with Account
AddContactEnryIdsFromAccount objNS, _
bcmRootFolder, _
CStr(oParentEntryID.value), _
astrContactEntryIDs
End If
' Business Project
Case "IPM.Task.BCM.Project":
AddContactEntryIDsFromProject objNS, _
bcmRootFolder, oItem, astrContactEntryIDs
Case Else:
' Invalid BCM type
Exit Function
End Select
End If
Next ' Add selected items
' Add recipients
If astrContactEntryIDs(0) = "" Then