add an existing pdf to an open outlook item

B

BORUCH

Well-known Member
Joined
Mar 1, 2016
Messages
528
Office Version
  1. 365
Platform
  1. Windows
hi all

I have the below code which inserts the active sheet as a pdf in an outlook email attachment

VBA Code: 
Sub Email_ActiveSheet_As_PDF5211111()
    Dim OlApp As Object
    Dim NewMail As Object
    Dim TempFilePath As String
    Dim strbody As String
    Dim signature As String
    Dim TempFileName As String
    Dim FileFullPath As String
    Dim bb As String
    Dim Ext As String
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    If Worksheets("rrInvoice").Range("H4") = "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    bb = "Order #" & " " & Worksheets("rrInvoice").Range("G8")
    ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    bb = "Invoice #" & " " & Worksheets("rrInvoice").Range("H4")
    ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Credit" Then
    bb = "Credit #" & " " & Worksheets("rrInvoice").Range("H4")
    End If
    If Application.UserName = "jack" Then
    Ext = "0"
    End If
    TempFilePath = Environ$("temp") & "\"
    TempFileName = bb & ".pdf"
    FileFullPath = TempFilePath & TempFileName
    On Error GoTo err
    With ActiveSheet
        .ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    End With
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
    On Error Resume Next
   With NewMail
    .Display
   End With
        signature = NewMail.HTMLBody
   If Worksheets("rrInvoice").Range("H4") = "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
"Please see the attached order." & "</b> " & "<br><br>" & _
"Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
"Thank you for your business."
ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
"Please see the attached invoice." & "</b> " & "<br><br>" & _
"Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
"Thank you for your business."
ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Credit" Then
strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
"Please see the attached Credit." & "</b> " & "<br><br>" & _
"Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
"Thank you for your business."
End If
    With NewMail
        .To = ""
        .CC = ""
        .Subject = bb
        .HTMLBody = strbody & signature
        .Attachments.Add FileFullPath
         .Display.To
    End With
    On Error GoTo 0
    Kill FileFullPath
     Set NewMail = Nothing
    Set OlApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
   End With
    Exit Sub
err:
        MsgBox err.Description
End Sub

I would like to add one thing to this code, that if I already have an outlook email open with another pdf it should add the next active open pdf excel file to the original outlook item instead of creating a new outlook email also, I want to add to the subject the additional new file its adding.



Any help is greatly appreciated.
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Sort by date Sort by votes
BORUCH said:
hi all

I have the below code which inserts the active sheet as a pdf in an outlook email attachment

VBA Code: 
Sub Email_ActiveSheet_As_PDF5211111()
    Dim OlApp As Object
    Dim NewMail As Object
    Dim TempFilePath As String
    Dim strbody As String
    Dim signature As String
    Dim TempFileName As String
    Dim FileFullPath As String
    Dim bb As String
    Dim Ext As String
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    If Worksheets("rrInvoice").Range("H4") = "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    bb = "Order #" & " " & Worksheets("rrInvoice").Range("G8")
    ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    bb = "Invoice #" & " " & Worksheets("rrInvoice").Range("H4")
    ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Credit" Then
    bb = "Credit #" & " " & Worksheets("rrInvoice").Range("H4")
    End If
    If Application.UserName = "jack" Then
    Ext = "0"
    End If
    TempFilePath = Environ$("temp") & "\"
    TempFileName = bb & ".pdf"
    FileFullPath = TempFilePath & TempFileName
    On Error GoTo err
    With ActiveSheet
        .ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    End With
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
    On Error Resume Next
   With NewMail
    .Display
   End With
        signature = NewMail.HTMLBody
   If Worksheets("rrInvoice").Range("H4") = "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
"Please see the attached order." & "</b> " & "<br><br>" & _
"Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
"Thank you for your business."
ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
"Please see the attached invoice." & "</b> " & "<br><br>" & _
"Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
"Thank you for your business."
ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Credit" Then
strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
"Please see the attached Credit." & "</b> " & "<br><br>" & _
"Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
"Thank you for your business."
End If
    With NewMail
        .To = ""
        .CC = ""
        .Subject = bb
        .HTMLBody = strbody & signature
        .Attachments.Add FileFullPath
         .Display.To
    End With
    On Error GoTo 0
    Kill FileFullPath
     Set NewMail = Nothing
    Set OlApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
   End With
    Exit Sub
err:
        MsgBox err.Description
End Sub

I would like to add one thing to this code, that if I already have an outlook email open with another pdf it should add the next active open pdf excel file to the original outlook item instead of creating a new outlook email also, I want to add to the subject the additional new file its adding.



Any help is greatly appreciated.
Click to expand...
hi

can someone let me know if it is posibile to do what i want
 
Upvote 0
I’m looking to add an attachment to an open email in outlook i that possible ?
 
Upvote 0
Hi,

Try this code:
VBA Code: 
Sub AttachPDF()

  Const MyAttachment = "D:\Test.pdf" ' <-- Change to suit
 
  Const olMail = 43

  With GetObject(, "Outlook.Application").ActiveInspector.CurrentItem
   
    On Error Resume Next
    If .Class <> olMail Then
      MsgBox "Active Outlook item should be email!", vbExclamation, "Exit"
      Exit Sub
    End If
    On Error GoTo 0
   
    .Attachments.Add MyAttachment
    .Display
   
  End With
 
End Sub
 
Last edited:
Upvote 0
After checking that my previous code adds the attachment file D:\Test.pdf to the already open Outlook's email,
replace this part of your code:
VBA Code: 
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
    On Error Resume Next
By that code:
VBA Code: 
  On Error Resume Next
  Set OlApp = GetObject(, "Outlook.Application")
  If Err Then
    ' Create new email
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
  Else
    ' Try using active email
    Set NewMail = OlApp.ActiveInspector.CurrentItem
    ' If current outlook item is not email object then create the new one
    If NewMail.Class <> 43 Then Set NewMail = OlApp.CreateItem(0)
  End If
  On Error GoTo 0

Also do not use any reserved VBA words like your err label in the On Error GoTo err - replace err by something unique like err_handler
 
Last edited:
Upvote 0
ZVI said:
After checking that my previous code adds the attachment file D:\Test.pdf to the already open Outlook's email,
replace this part of your code:
VBA Code: 
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
    On Error Resume Next
By that code:
VBA Code: 
  On Error Resume Next
  Set OlApp = GetObject(, "Outlook.Application")
  If Err Then
    ' Create new email
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
  Else
    ' Try using active email
    Set NewMail = OlApp.ActiveInspector.CurrentItem
    ' If current outlook item is not email object then create the new one
    If NewMail.Class <> 43 Then Set NewMail = OlApp.CreateItem(0)
  End If
  On Error GoTo 0

Also do not use any reserved VBA words like your err label in the On Error GoTo err - replace err by something unique like err_handler
Click to expand...
Hi sorry for the late response

Thanks for the code

threre are just two minor problems
#1 im getting an error object required on the below line of code
VBA Code: 
.Display.To

#2 its duplicating the content in the body of the email all i want is that it should add to the subject the next invoice number
 
Upvote 0
Hi,

#1. Just delete code line with Display.To
#2. Here is full updated code:
VBA Code: 
Sub Email_ActiveSheet_As_PDF5211111()
  
  Dim OlApp As Object
  Dim NewMail As Object
  Dim TempFilePath As String
  Dim strbody As String
  Dim signature As String
  Dim TempFileName As String
  Dim FileFullPath As String
  Dim bb As String
  Dim Ext As String
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With
  
  If Worksheets("rrInvoice").Range("H4") = "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    bb = "Order #" & " " & Worksheets("rrInvoice").Range("G8")
  ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    bb = "Invoice #" & " " & Worksheets("rrInvoice").Range("H4")
  ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Credit" Then
    bb = "Credit #" & " " & Worksheets("rrInvoice").Range("H4")
  End If
  
  If Application.UserName = "jack" Then
    Ext = "0"
  End If
  
  TempFilePath = Environ$("temp") & "\"
  TempFileName = bb & ".pdf"
  FileFullPath = TempFilePath & TempFileName
  
  On Error GoTo err_handler
  With ActiveSheet
    .ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
  End With
  
  On Error Resume Next
  Set OlApp = GetObject(, "Outlook.Application")
  If Err Then
    ' Create new email
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
  Else
    ' Try using active email
    Set NewMail = OlApp.ActiveInspector.CurrentItem
    If NewMail.Class = 43 Then
      ' Active email found - add PDF and update subject
      With NewMail
        .Subject = .Subject & ", " & bb
        .Attachments.Add FileFullPath
        Kill FileFullPath
      End With
      MsgBox FileFullPath & " is added to the current email"
      Exit Sub
    Else
      ' If current outlook item is not email object then create the new one
      Set NewMail = OlApp.CreateItem(0)
    End If
  End If
  On Error GoTo 0
  
  With NewMail
    .Display
  End With
  
  signature = NewMail.HTMLBody
  If Worksheets("rrInvoice").Range("H4") = "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
              "Please see the attached order." & "</b> " & "<br><br>" & _
              "Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
              "Thank you for your business."
  ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
              "Please see the attached invoice." & "</b> " & "<br><br>" & _
              "Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
              "Thank you for your business."
  ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Credit" Then
    strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
              "Please see the attached Credit." & "</b> " & "<br><br>" & _
              "Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
              "Thank you for your business."
  End If
  
  With NewMail
    .To = ""
    .CC = ""
    .Subject = bb
    .HTMLBody = strbody & signature
    .Attachments.Add FileFullPath
  End With
  
  Kill FileFullPath
  Set NewMail = Nothing
  Set OlApp = Nothing
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
  Exit Sub
  
err_handler:
  If Err Then MsgBox Err.Description

End Sub
 
  • Like
Reactions: DDH
Upvote 0
ZVI said:
Hi,

#1. Just delete code line with Display.To
#2. Here is full updated code:
VBA Code: 
Sub Email_ActiveSheet_As_PDF5211111()
 
  Dim OlApp As Object
  Dim NewMail As Object
  Dim TempFilePath As String
  Dim strbody As String
  Dim signature As String
  Dim TempFileName As String
  Dim FileFullPath As String
  Dim bb As String
  Dim Ext As String
 
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With
 
  If Worksheets("rrInvoice").Range("H4") = "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    bb = "Order #" & " " & Worksheets("rrInvoice").Range("G8")
  ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    bb = "Invoice #" & " " & Worksheets("rrInvoice").Range("H4")
  ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Credit" Then
    bb = "Credit #" & " " & Worksheets("rrInvoice").Range("H4")
  End If
 
  If Application.UserName = "jack" Then
    Ext = "0"
  End If
 
  TempFilePath = Environ$("temp") & "\"
  TempFileName = bb & ".pdf"
  FileFullPath = TempFilePath & TempFileName
 
  On Error GoTo err_handler
  With ActiveSheet
    .ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=FileFullPath, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
  End With
 
  On Error Resume Next
  Set OlApp = GetObject(, "Outlook.Application")
  If Err Then
    ' Create new email
    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)
  Else
    ' Try using active email
    Set NewMail = OlApp.ActiveInspector.CurrentItem
    If NewMail.Class = 43 Then
      ' Active email found - add PDF and update subject
      With NewMail
        .Subject = .Subject & ", " & bb
        .Attachments.Add FileFullPath
        Kill FileFullPath
      End With
      MsgBox FileFullPath & " is added to the current email"
      Exit Sub
    Else
      ' If current outlook item is not email object then create the new one
      Set NewMail = OlApp.CreateItem(0)
    End If
  End If
  On Error GoTo 0
 
  With NewMail
    .Display
  End With
 
  signature = NewMail.HTMLBody
  If Worksheets("rrInvoice").Range("H4") = "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
              "Please see the attached order." & "</b> " & "<br><br>" & _
              "Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
              "Thank you for your business."
  ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Invoice" Then
    strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
              "Please see the attached invoice." & "</b> " & "<br><br>" & _
              "Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
              "Thank you for your business."
  ElseIf Worksheets("rrInvoice").Range("H4") <> "" And Worksheets("rrInvoice").Range("G1") = "Credit" Then
    strbody = "<BODY style=font-size:12pt;font-family:Calibri>" & _
              "Please see the attached Credit." & "</b> " & "<br><br>" & _
              "Any questions or concerns please feel free to contact me at 000-000-0000." & " " & "Ext." & " " & Ext & "</b> " & "<br><br>" & _
              "Thank you for your business."
  End If
 
  With NewMail
    .To = ""
    .CC = ""
    .Subject = bb
    .HTMLBody = strbody & signature
    .Attachments.Add FileFullPath
  End With
 
  Kill FileFullPath
  Set NewMail = Nothing
  Set OlApp = Nothing
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
  Exit Sub
 
err_handler:
  If Err Then MsgBox Err.Description

End Sub
Click to expand...
Thank you very much that works perfectly
 
  • Like
Reactions: DDH
Upvote 0
You are welcome, thank you for the feedback!
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Excel VBA to email multiple ranges as a PDF
Replies
0
Views
693
shophoney
S
J
  • Question
Outlook Hypperlink of fila in email body will not open
Replies
1
Views
454
josros60
J
Z
  • Question
VBA code to create a new workbook from multiple sheets of current workbook
Replies
9
Views
2K
Micron
M
K
  • Question
Modifying Existing VBA Code to add 2 additional data columns
Replies
0
Views
153
keranali
K
E
  • Question
Adding a custom message.
Replies
1
Views
447
Micron
M

Forum statistics

Threads
1,215,504
Messages
6,125,185
Members
449,213
Latest member
Kirbito

Share this page

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
Back
Top