Emailing a PPTX as a PDF in Outlook

[RayKay]

Hi all, and John of course.

I've looked everywhere online, but nothing, and my coded attempts fail

I have code for sending selected slides as a PPTX file attachment in Outlook, but I really need to have it where it attaches selected slides as a PDF as an attachment. Any ideas? Thank you

Code for attaching as a PPTX (but I need it as a PDF):

Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim otemp As Presentation
Dim opres As Presentation
Dim strName As String
Dim strSubject As String

Dim L As Long
Dim raySlides() As Long
Set opres = ActivePresentation

Call zaptags(opres)

strSubject = opres.Name
strName = killSuffix(opres.Name) & " s_"
ReDim raySlides(1 To ActiveWindow.Selection.SlideRange.Count)
For L = 1 To ActiveWindow.Selection.SlideRange.Count
ActiveWindow.Selection.SlideRange(L).Tags.Add "SELECTED", "YES"
If L <> ActiveWindow.Selection.SlideRange.Count Then
strName = strName & ActiveWindow.Selection.SlideRange(L).SlideIndex & "_"
Else
strName = strName & ActiveWindow.Selection.SlideRange(L).SlideIndex
End If
Next L

' make a copy
opres.SaveCopyAs Environ("TEMP") & "" & strName & ".pptx"
'open the copy
Set otemp = Presentations.Open(Environ("TEMP") & "" & strName & ".pptx")
'delete unwanted slides
For L = otemp.Slides.Count To 1 Step -1
Debug.Print otemp.Slides(L).Tags("SELECTED")
If otemp.Slides(L).Tags("SELECTED") <> "YES" Then otemp.Slides(L).Delete
Next L
otemp.Save
otemp.Close

On Error Resume Next
Set OutlookApp = GetObject(class:="Outlook.Application")
err.Clear
If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application")
On Error GoTo 0
Set OutlookMessage = OutlookApp.CreateItem(0)

On Error Resume Next
With OutlookMessage
.To = ""
.CC = ""
.Subject = strSubject
.Body = "Please see slides attached."
.Attachments.Add Environ("TEMP") & "" & strName & ".pptx"
.Display

End With
End Sub

Sub zaptags(opres)
Dim oSld As Slide
On Error Resume Next
For Each oSld In opres.Slides
oSld.Tags.Delete ("SELECTED")
Next oSld
End Sub

Function killSuffix(strName As String) As String
Dim ipos As Integer
ipos = InStrRev(strName, ".")
If ipos > 0 Then
killSuffix = Left(strName, ipos - 1)
Else: killSuffix = strName
End If
End Function

[John Wilson]

First you changed the code you copied removing the"" before the file name when you save to the TEMP folder. This is why your files have a TEmp prefix

You just need to save the temp file again as a PDF and of course point the attachment at the PDF file

Sub SendPDF()
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim otemp As Presentation
Dim opres As Presentation
Dim strName As String
Dim strSubject As String


Dim L As Long
Dim raySlides() As Long
Set opres = ActivePresentation


Call zaptags(opres)


strSubject = opres.Name
strName = killSuffix(opres.Name) & " s_"
ReDim raySlides(1 To ActiveWindow.Selection.SlideRange.Count)
For L = 1 To ActiveWindow.Selection.SlideRange.Count
ActiveWindow.Selection.SlideRange(L).Tags.Add "SELECTED", "YES"
If L <> ActiveWindow.Selection.SlideRange.Count Then
strName = strName & ActiveWindow.Selection.SlideRange(L).SlideIndex & "_"
Else
strName = strName & ActiveWindow.Selection.SlideRange(L).SlideIndex
End If
Next L


' make a copy
opres.SaveCopyAs Environ("TEMP") & "\" & strName & ".pptx"
'open the copy
Set otemp = Presentations.Open(Environ("TEMP") & "\" & strName & ".pptx")
'delete unwanted slides
For L = otemp.Slides.Count To 1 Step -1
Debug.Print otemp.Slides(L).Tags("SELECTED")
If otemp.Slides(L).Tags("SELECTED") <> "YES" Then otemp.Slides(L).Delete
Next L
otemp.SaveAs Environ("TEMP") & "\" & strName & ".pdf", ppSaveAsPDF
otemp.Close


On Error Resume Next
Set OutlookApp = GetObject(class:="Outlook.Application")
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application")
On Error GoTo 0
Set OutlookMessage = OutlookApp.CreateItem(0)


On Error Resume Next
With OutlookMessage
.To = ""
.CC = ""
.Subject = strSubject
.Body = "Please see slides attached."
.Attachments.Add Environ("TEMP") & "\" & strName & ".pdf"
.Display


End With
End Sub


Sub zaptags(opres)
Dim oSld As Slide
On Error Resume Next
For Each oSld In opres.Slides
oSld.Tags.Delete ("SELECTED")
Next oSld
End Sub


Function killSuffix(strName As String) As String
Dim ipos As Integer
ipos = InStrRev(strName, ".")
If ipos > 0 Then
killSuffix = Left(strName, ipos - 1)
Else: killSuffix = strName
End If
End Function

[RayKay]

Great! Thanks so much, I can work with this. Have a great day!

[RayKay]

Hi John

How would one edit this code so it emailed in Outlook:

i. The entire file as a PDF
ii. Doesn't ask you to save the PPTX file before attaching the PDF to an email?

I've deleted numerous 'blocks' of code, but again, stumped. Thank you.