Pat,
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
' Unable to find recipient
Exit Function
Else
For Each contactEntryID In astrContactEntryIDs
If contactEntryID = "" Then
MsgBox "Warning: Contact not found"
Else
strRecipientXML = strRecipientXML & _
" <CampaignRecipient>" & _
" <EntryID>" & contactEntryID & "</EntryID>" & _
" </CampaignRecipient>"
End If
Next
End If
' Close the recipient list
strRecipientXML = strRecipientXML & "</ArrayOfCampaignRecipient>"
' Example XML for an external list of leads
Dim strExternalRecipientXML
strExternalRecipientXML = _
"<ArrayOfCampaignRecipient>" & _
" <CampaignRecipient>" & _
" <FileAs>Ashton, Chris</FileAs>" & _
" <EmailAddress>
[email protected]</EmailAddress>" & _
" </CampaignRecipient>" & _
"</ArrayOfCampaignRecipient>"
Set oParent = Nothing
Set oParentEntryID = Nothing
Set oItem = Nothing
' Return the Recipient List XML
GetRecipientXML = strRecipientXML
End Function
' Returns an array of Business Contact EntryID's for the given Account
Sub AddContactEnryIdsFromAccount(objNS As Outlook.NameSpace, _
bcmRootFolder As Outlook.Folder, _
strAccountID As String, _
astrContactIDs() As String)
' Check for a valid BCM root folder and Account EntryID
If objNS Is Nothing Or _
bcmRootFolder Is Nothing Or _
Trim(strAccountID) = "" Then
Exit Sub
End If
' Ensure that this is a BCM Account
On Error Resume Next
Dim oItem As Object
Set oItem = objNS.GetItemFromID(strAccountID)
If Err.Number <> 0 Then
Exit Sub
End If
If oItem Is Nothing Then
Exit Sub
End If
If oItem.MessageClass <> "IPM.Contact.BCM.Account" Then
Exit Sub
End If
Set oItem = Nothing
On Error GoTo 0
' Locate the Business Contacts folder
Dim businessContacts As Outlook.Folder
Set businessContacts = _
bcmRootFolder.Folders("Business Contacts")
If businessContacts Is Nothing Or _
businessContacts.Items Is Nothing Then
Exit Sub
End If
' Setup the filter restriction string
Dim strRestriction As String
strRestriction = "[Parent Entity EntryID] = '" & strAccountID & "'"
Dim accountContacts As Outlook.Items
Set accountContacts = businessContacts.Items.Restrict(strRestriction)
If accountContacts Is Nothing Then
Exit Sub
End If
' Add each contact to the list of Account contacts
Dim oContact As Object
Dim i As Integer
For Each oContact In accountContacts
If oContact Is Nothing Then
MsgBox ("Invalid contact")
Else
AddCampaignRecipient astrContactIDs, oContact.EntryID
End If
Next
Set accountContacts = Nothing
Set businessContacts = Nothing
End Sub
' Get EntryID's for Project's related Business Contacts and Accounts
Sub AddContactEntryIDsFromProject(objNS As Outlook.NameSpace, _
bcmRootFolder As Outlook.Folder, _
oProject As Outlook.TaskItem, _
astrContactIDs() As String)
' Check parameters
If objNS Is Nothing Or _
bcmRootFolder Is Nothing Or _
oProject Is Nothing Then
Exit Sub
End If
' Get the project's parent item
Dim oParentEntryID As Object
Set oParentEntryID = oProject.UserProperties("Parent Entity EntryID")
If oParentEntryID Is Nothing Then
MsgBox ("This project is not linked to a " & _
"Business Contact or Account")
Exit Sub
Else
AddCampaignRecipient astrContactIDs, oParentEntryID.value
' If the parent is an Account, add its contacts too
AddContactEnryIdsFromAccount objNS, bcmRootFolder, _
oParentEntryID.value, astrContactIDs
End If
' Get associated contacts
Dim associatedContacts As Outlook.userProperty
Set associatedContacts = _
oProject.UserProperties("Associated Contacts")
If (associatedContacts Is Nothing) Then
Exit Sub
End If
projectContacts = associatedContacts.value
Dim projectContactID As Variant
Dim i As Integer
On Error Resume Next
For Each projectContactID In projectContacts
If IsObject(projectContactID) Then
MsgBox ("Invalid contact")
Else
AddCampaignRecipient astrContactIDs, CStr(projectContactID)
' If the related contact is an Account, add its contacts too
AddContactEnryIdsFromAccount objNS, bcmRootFolder, _
CStr(projectContactID), _
astrContactIDs
End If
Next
On Error GoTo 0
Set associatedContacts = Nothing
Set oParentEntryID = Nothing
End Sub
' Add a unique campaign recipient to the given array
Sub AddCampaignRecipient(ByRef astrRecipientIDs() As String, _
recipientID As String)
Dim arrFilter() As String
' Check to see if this is a duplicate recipient
arrFilter = Filter(astrRecipientIDs, recipientID, True, vbTextCompare)
If UBound(arrFilter) < 0 Then
Dim i As Integer
i = UBound(astrRecipientIDs)
' See if we need to grow the array length
If i > 0 Or astrRecipientIDs(0) <> "" Then
i = i + 1
ReDim Preserve astrRecipientIDs(0 To i)
End If
' Add this recipient to our list
astrRecipientIDs(i) = recipientID
End If
End Sub
'//////////////////////////////////////////////////////////////////////////
