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.
 
Sort by date Sort by votes
ZVI said:
You are welcome, thank you for the feedback!
Click to expand...
hi
there seems to be a minor problem with the code in a scenario where the outlook application is open but there is no open email it just does nothing
what it should do is create a new email can that be fixed

thanks
 
Upvote 0

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
BORUCH said:
hi
there seems to be a minor problem with the code in a scenario where the outlook application is open but there is no open email it just does nothing
what it should do is create a new email can that be fixed

thanks
Click to expand...
Hi,
Try this:
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")
  Else
    ' Try using active email
    Set NewMail = OlApp.ActiveInspector.CurrentItem
    If Not NewMail Is Nothing Then
      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
      End If
    End If
  End If
  On Error GoTo 0
  
  ' Create new email
  Set NewMail = OlApp.CreateItem(0)
  NewMail.Display
  
  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
 
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
669
shophoney
S
J
  • Question
Outlook Hypperlink of fila in email body will not open
Replies
1
Views
434
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
140
keranali
K
E
  • Question
Adding a custom message.
Replies
1
Views
429
Micron
M

Forum statistics

Threads
1,215,006
Messages
6,122,666
Members
449,091
Latest member
peppernaut

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