Email PDF code - save a copy

MOB

Well-known Member
Joined
Oct 18, 2005
Messages
995
Using this code from ZVI's examples on another thread - it kills the PDF at the end, how can I make it save a copy in a location, with the file name from cell C4?

Code:
Sub AttachActiveSheetPDF()
  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object
 
  ' Not sure for what the Title is
  Title = Range("A7")
 
  ' Define PDF filename
  PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"
 
  ' Export activesheet as PDF
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, FileName:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With
 
  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0
 
  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
   
    ' Prepare e-mail
    .Subject = Title
    .To = "xxxxxxxxxxxxxxxxxxx" ' <-- Put email of the recipient here
    .CC = "" ' <-- Put email of 'copy to' recipient here
    .Body = "Hi," & vbLf & vbLf _
          & "The report is attached in PDF format." & vbLf & vbLf _
          & "Regards," & vbLf _
          & Application.UserName & vbLf & vbLf
    .Attachments.Add PdfFile
   
    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
    Else
      MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
   
  End With
 
  ' Delete PDF file
  Kill PdfFile
 
  ' Quit Outlook if it was created by this code
  If IsCreated Then OutlApp.Quit
 
  ' Release the memory of object variable
  Set OutlApp = Nothing
 
End Sub
 
Last edited:

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
5,949
Replace:
Code:
  PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"
with:
Code:
PdfFile = ActiveSheet.Range("C4").Value
(assumes C4 contains the full folder path and file name including .pdf extension) and delete the Kill statement.
 

MOB

Well-known Member
Joined
Oct 18, 2005
Messages
995
One minor change required - in cell C4 I am entering for example g:\test.pdf

Is it possible to also save an excel copy eg g:\test.xlsm

What is the best way to do this - another cell with the xlsm text in it?

TIA
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
5,949
Using C4:

Code:
ThisWorkbook.SaveCopyAs Replace(Range("C4").Value, ".pdf", ".xlsm")
 

Forum statistics

Threads
1,078,218
Messages
5,338,913
Members
399,267
Latest member
Danielle1017

Some videos you may like

This Week's Hot Topics

Top