add an existing pdf to an open outlook item

BORUCH

Active Member
Joined
Mar 1, 2016
Messages
371
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.
 

BORUCH

Active Member
Joined
Mar 1, 2016
Messages
371
Office Version
  1. 365
Platform
  1. Windows
You are welcome, thank you for the feedback!
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
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,845
Office Version
  1. 2019
  2. 2016
  3. 2010
Platform
  1. Windows
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
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
 

Forum statistics

Threads
1,144,162
Messages
5,722,847
Members
422,460
Latest member
VBA_Noob01

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