See it in Action!Watch this video to see this macro in action.
The CodeHere is the code for this macro. Make sure the following References are setup before running it: Visual Basic For Applications, Microsoft Outlook 16.0 Object Library The CopyAtts portion of this code is leveraged from page 613 of Microsoft Outlook 2007 Programming by Sue Mosher.
'Leverage & Lean "Less Clicks, More Results" Sub SendSameEmailDifferentRecipients() ' Means variable is in use Dim Body As String ' Dim CCRecipients As String ' Dim EmailCounter As String ' Dim NewEmail As Object ' Dim oItem As MailItem ' Dim Outlook As Object ' Dim Recipients As String ' Dim Subject As String ' On Error GoTo LeverageLean 'From current email copy the Subject and Body Set oItem = Application.ActiveInspector.CurrentItem Subject = oItem.Subject Body = oItem.HTMLBody EmailCounter = 0 Do Until EmailCounter = "" EmailCounter = EmailCounter + 1 If EmailCounter = "1" Then Recipients = "" CCRecipients = "" ElseIf EmailCounter = "2" Then Recipients = "" CCRecipients = "" ElseIf EmailCounter = "3" Then Recipients = "" CCRecipients = "" ElseIf EmailCounter = "4" Then Recipients = "" CCRecipients = "" ElseIf EmailCounter = "5" Then Recipients = "" CCRecipients = "" Else 'No additional Recipients set so clear EmailCounter. EmailCounter = "" Recipients = "" End If If Recipients <> "" Then Set Outlook = CreateObject("Outlook.Application") Set NewEmail = Outlook.CreateItem(0) NewEmail.To = Recipients 'Set Recipients indicated by EmailCounter above NewEmail.CC = CCRecipients 'Set CCRecipients indicated by EmailCounter above NewEmail.Subject = Subject 'Set Subject from the Current Email NewEmail.HTMLBody = Body 'Set Body from the Current Email If oItem.Attachments.Count > 0 Then Call CopyAtts(oItem, NewEmail) 'Call Macro to Copy Attachments from one Email to another End If NewEmail.Display 'NewEmail.Send End If Loop Exit Sub LeverageLean: MsgBox (Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & "Don't hesitate to email me: firstname.lastname@example.org") End Sub Sub CopyAtts(Source, Target) 'p.613-Microsoft Outlook 2007 Programming-Sue Mosher Dim objFSO, fldTemp, strpath, strFile Dim objAtt, blnUseTempFile Const olByRefernce = 4 Const olByValue = 1 Const olEmbeddeditem = 5 Const TemporaryFolder = 2 Set objFSO = CreateObject("Scripting.FileSystemObject") Set fldTemp = objFSO.GetSpecialFolder(TemporaryFolder) strpath = fldTemp.Path & "\" For Each objAtt In Source.Attachments Select Case objAtt.Type Case olByReference strFile = objAtt.PathName blnUseTempFile = False Case olByValue, olEmbeddeditem strFile = strpath & objAtt.Filename objAtt.SaveAsFile strFile blnUseTempFile = True End Select If blnUseTempFile Then Target.Attachments.Add strFile, olByValue objFSO.DeleteFile strFile Else Target.Attachments.Add strFile, olByReference End If Next Set fldTemp = Nothing Set objFSO = Nothing End Sub 'Stay Awesome
Macro MondayHere is the Macro Monday video this macro was featured in. Watch this video to learn how to get the most out of this macro and start using it today!
CustomizationThese lines of code can be customized to personalize this macro.
24 through 38 Recipients = “” CCRecipients = “” To add Recipients and CC Recipients update these variables with email addresses throughout these code lines.
55. ‘NewEmail.Send To automatically send these generated emails remove the ‘ so this code lines is no longer a comment.