Add multiple attachments within Outlook Body

[Harshil Mehta]

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?

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

 

[eastrand]

Untested!

I do it like this. The below code will cover up to 9 attachments, but you can increase or decrease that as needed.

Dim myFileList(9) as String
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*", " ")

       myFileList(0) ="C:\Users\" & ThisWorkbook.Sheets("Dashboard").Range("E5") & "\Desktop\Jan.pdf" ', olByValue, p1, "file1"
       myFileList(1) ="C:\Users\" & ThisWorkbook.Sheets("Dashboard").Range("E5") & "\Desktop\Feb.pdf" ', olByValue, p2, "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
              
                     For i = 0 To 8
                        If myFileList(i) <> Empty Then
                        .Attachments.Add myFileList(i)
                        Else
                        Exit For
                        End If
                    Next i
        
        
           '.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

 

[abc_xyz]

Thanks

Untested!

I do it like this. The below code will cover up to 9 attachments, but you can increase or decrease that as needed.

Dim myFileList(9) as String
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*", " ")

       myFileList(0) ="C:\Users\" & ThisWorkbook.Sheets("Dashboard").Range("E5") & "\Desktop\Jan.pdf" ', olByValue, p1, "file1"
       myFileList(1) ="C:\Users\" & ThisWorkbook.Sheets("Dashboard").Range("E5") & "\Desktop\Feb.pdf" ', olByValue, p2, "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
             
                     For i = 0 To 8
                        If myFileList(i) <> Empty Then
                        .Attachments.Add myFileList(i)
                        Else
                        Exit For
                        End If
                    Next i
       
       
           '.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

for the code but the output is still the same.

 

[eastrand]

What is the result? Is it just attaching one file or are you getting an error? Is this just for the text of the body? Try using .HTMLbody instead of just .body

 

[Harshil Mehta]

What is the result? Is it just attaching one file or are you getting an error? Is this just for the text of the body?

It is attaching both the files but not in the format I want. The desired format is shown above.

 

[eastrand]

Try using .HTMLbody instead of just .body

 

[Harshil Mehta]

Tried. Does not work

Try using .HTMLbody instead of just .body

 

[eastrand]

Maybe I'm not understanding the wanted outcome. It looks like you are trying to attach a .pdf into the body of the email. Are you wanting to be able to view the .pdf within the body of the email or just have it as an attachment on the email to open separately? I know you can attach .jpg and other pic files within the body but not aware of a way to attach a .pdf within the body. Am I missing something?

 

[Harshil Mehta]

Yes, I want the attachments to be pasted within the body itself.

Maybe I'm not understanding the wanted outcome. It looks like you are trying to attach a .pdf into the body of the email. Are you wanting to be able to view the .pdf within the body of the email or just have it as an attachment on the email to open separately? I know you can attach .jpg and other pic files within the body but not aware of a way to attach a .pdf within the body. Am I missing something?

 

[eastrand]

Again, I'm not sure if that is possible. I'll wait for the others to weigh in. Good luck though.