Unable to attach multiple embedded PDF from excel into Outlook

[Cheng Yee]

Hi, I am unable to attach multiple embedded PDF from excel into Outlook. To attach single embedded PDF is working fine if the PDF size is no more than 20 KB. For the multiple embedded PDF, my end result will be taking the last embedded PDF.

My questions has 2:

2. How to reduce the PDF size by using VBA so that I will not have the limit of <20KB to upload?

Or, how I can give instruction toexcel I don’t want to have the limitation of the embedded PDF?

2. How to set the VBA coding to allow the multiple embedded PDF able to publish with multiple attachment in Outlook?

Here is the coding. Many thanks for your advice
Sub Approver()
ActiveSheet.Unprotect "financeispl2010"
If Range("C35").Value = Application.UserName Then
MsgBox ("Approver must not be the same person as the requestor!")
Exit Sub
End If
'Test if the value is cell A1 is blank/empty
If IsEmpty(Range("C35").Value) = True Then
MsgBox ("Requestor name is empty!")
Exit Sub
End If
Range("I35").Value = Application.UserName
Range("I36").Value = Date
Dim DestPath, Fname, Embed, QueryAddress As String

On Error Resume Next
MkDir "C:\PaymentRequestForm"
Application.DisplayAlerts = False
DestPath = "C:\PaymentRequestForm"

Fname = Range("J5").Value & ".pdf"
Embed = Range("J5").Value & "_attachment.pdf"

Application.DisplayAlerts = False
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=DestPath & Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

Application.DisplayAlerts = True

PrintEmbeddedPDFs_02

QueryAddress = Range("AZ41")

Dim olApp As Object
Dim olMail As Object
Dim objOutlookAttach As Object

Set olApp = CreateObject("Outlook.Application")
olApp.Session.Logon
Application.ScreenUpdating = False
Application.EnableEvents = False
Set olMail = olApp.CreateItem(0)
With olMail
.To = QueryAddress
.CC = ""
.BCC = ""
.Subject = Range("J5").Value
.HTMLBody = "Click Send in Outlook to deliver the Payment Request Form to GSSC Payables Team.<br><br><br>Note: <br>"
.Attachments.Add DestPath & Fname
If Dir(DestPath & Embed) <> "" Then .Attachments.Add DestPath & Embed
.Display
End With

On Error Resume Next

Kill DestPath & Fname
Kill DestPath & Embed

If Dir(DestPath & "*.*") <> "" Then
Do While Dir(DestPath & "*.*") <> ""
Kill DestPath & Dir(DestPath & "*.*")
Loop
End If

If Dir("C:\PaymentRequestForm", vbDirectory) <> "" Then RmDir "C:\PaymentRequestForm"

ActiveSheet.Protect "financeispl2010"

End Sub