Add multiple attachments within Outlook Body

Harshil Mehta

Board Regular
Joined
May 14, 2020
Messages
84
Office Version
  1. 2013
Platform
  1. Windows
I am working on a file wherein I have to add multiple attachments within the Outlook mail body using the RICH TEXT function.

Below is the desired output:

Start of the email text

Part 1 Text
FILE 1 & FILE2

Part 2 Text
FILE 1 & FILE2

End of email text


However, my code seems to add the attachment files only after the Part2 Text. Could anyone please help me with the code?


VBA Code:
Sub Prepare_Drafts()
  
Dim OutApp As Object
Dim Default_Body As String
Dim shs As Worksheet
Dim File_Name As String
Dim p1 As Long, p2 As Long, p3 As Long


Application.ScreenUpdating = False



For Each shs In Sheets

shs.Activate
shs.Calculate

    If shs.Name <> "Dashboard" Then
    
       On Error Resume Next
       
       
       Set OutApp = GetObject(, "Outlook.Application")
       File_Name = shs.Range("D5").Value
  
 
 Default_Body = "Start of email text." & vbCr & vbCr & _
"Part 1 Text" & vbCr & _
"*FILE1*" & "*FILE2*" & vbCr & vbCr & _
"Part 2 Text" & vbCr & _
"*FILE1*" & "*FILE2*" & vbCr & vbCr & _
"End of email text."
    
    p1 = InStr(Default_Body, "*FILE1*")
    Default_Body = Replace(Default_Body, "*FILE1*", " ")
    
    p2 = InStr(Default_Body, "*FILE2*")
    Default_Body = Replace(Default_Body, "*FILE2*", " ")
 
 
 
       With OutApp.CreateItem(0)
           .BodyFormat = 3
           .To = shs.Range("D7").Value
           .CC = shs.Range("D11").Value
           .BCC = ""
           .Subject = shs.Range("D17").Value
           
           .Body = Default_Body
           .Attachments.Add "C:\Users\" & ThisWorkbook.Sheets("Dashboard").Range("E5") & "\Desktop\Jan.pdf" ', olByValue, p1, "file1"
           .Attachments.Add "C:\Users\" & ThisWorkbook.Sheets("Dashboard").Range("E5") & "\Desktop\Feb.pdf" ', olByValue, p2, "file2"
           
           
           '.SaveAs "C:\Users\" & ThisWorkbook.Sheets("Dashboard").Range("E5") & "\Desktop\" & File_Name ', olTemplate
           .display
       End With
 
 
       Set OutApp = Nothing
  
   End If
  
Next shs



Sheets("Dashboard").Activate

Application.ScreenUpdating = True

End Sub
 

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
40,116
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS
Welcome to the MrExcel Message Board!

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Multiple attachments in email body
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.
 
Upvote 0

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

Forum statistics

Threads
1,186,312
Messages
5,957,137
Members
438,289
Latest member
donnabee

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top