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
       ' 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>cashton@contosopharm.com</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
'//////////////////////////////////////////////////////////////////////////