Macro to send a single slide as Outlook attachment

Ahoi everyone, first time poster here!

I hope I’m posting this in the right place. I’m looking for a Macro/VBA (I’m not a tech guy, so I use words interchangeably which I shouldn’t, I apologise in advance), to save me hours of time.

What I would aim to do with this VBA code is the following – In PowerPoint, I would like to add a button to my toolbar which has the ability to take the slide I have selected, open my Outlook and put it in as an attachment. The reason this would be so useful, is because currently every time I work on only one slide in a deck and would like to share it, I have to manually make a new presentation (which usually destroys the format), copy my slide into it, rename and then attach it. I’m hoping a macro would simplify my life by automatically doing the majority of these steps, and having a button to do all this would be perfect. In addition, the dream would be to be able to input a range of slides I could do that same for.

If anyone is able to do this please drop me an email or reply to this thread. I would also be more than happy to provide a small donation to anyone who sacrifices some of their time to ensure this works for me.
At some point it may be necessary to tell you what version of PPT and Outlook I have, or is this not relevant?

Thanks!

Alex.

This is just code from the top of my head. It will need some error checks at least. Should get you going though.

Code:

---

Sub sendMail()
  Dim OutlookApp As Object
  Dim OutlookMessage As Object
  Dim otemp As Presentation
  Dim opres As Presentation
  Dim L As Long
  Set opres = ActivePresentation
  ActiveWindow.Selection.SlideRange(1).Tags.Add "SELECTED", "YES"
  ' make a copy
  opres.SaveCopyAs Environ("TEMP") & "\temp.pptx"
  'open the copy
  Set otemp = Presentations.Open(Environ("TEMP") & "\temp.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 = "john@alchemy.co.uk" 'CHANGE THIS!
      .CC = ""
      .Subject = "Attached PPT"
      .Body = "A slide is attached. John"
      .Attachments.Add Environ("TEMP") & "\temp.pptx"
      .Display
      .Send
  End With
End Sub

---

Thanks John,

As you've probably noticed this worked extremely well, thank you for this! It still impresses me at how easily people can code.
A couple of things that I would really appreciate to have streamlined:

1) Would it be possible to bring up a dialog box where I can enter the number of the slide(s) I would like to attach, or a range of slides to be included in the attached message? I.e. either a '7' or '7-13'
2) Additionally is it possible to give the PPT that is attached the same name of the initial file but with the slide number(s) to the end of it? I.e. Presentation1_s7to13

EDIT: Maybe a 3) Would it possible to make the subject of the email the name of the attached Document too? :)

I realise that this is a big ask and I am grateful for any guidance, so drop me an email if you would like some compensation or a donation to a charity of your choice.

Kind regards,
Alex.

I don't need compensation but I don't have a lot of time right now so you will have to wait a few days.

This is the best I can do in the time I have.

It would be possible to have a dialog to show which slides to send but much easier to ctrl Click to select the slides needed.

The slide numbers in the file name will most likely be out of order. This can be fixed but again it would take time I don't have right now. Hope it help anyway.

Code:

---

Sub sendMail()   
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
    strSubject = opres.Name
    strName = 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 = "john@alchemy.co.uk" 'CHANGE THIS!
        .CC = ""
        .Subject = strSubject
        .Body = "Slides are attached. John"
        .Attachments.Add Environ("TEMP") & "\" & strName & ".pptx"
        .Display
        .Send
    End With
End Sub

---

Thanks a lot John, much appreciated.
It works almost perfectly, and nothing I can't fix without dissecting the code for a little while.
A.

Hi John,
I've been trying to figure out an issue I was having with this code. It almost works perfectly apart from one tiny issue. The first time I run the code it runs smoothly and all the correct slides are attached, however on following attempts, certain additional slides that are not included in the current selected range are also taken into the new PPT and attached. I feel this probably has something to do with the assigned tags of the previously selected slides which aren't deleted after the code has run.
Is this the reason behind the error and do you know the remedy to this issue?

Thanks again,
A.

Still untested top of head code but you should be able to do this

Code:

---

Sub sendMail()

    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 = 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 = "john@alchemy.co.uk" 'CHANGE THIS!
        .CC = ""
        .Subject = strSubject
        .Body = "Slides are attached. John"
        .Attachments.Add Environ("TEMP") & "\" & strName & ".pptx"
        .Display
        .Send
    End With
End Sub


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

---

Figured it out, thanks a lot John. Below the fully functional version if anyone is interested.

Sub Attach_selected_slides()

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 = 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 = "ENTEREMAIL" Insert email address here!
.CC = ""
.Subject = strSubject
.Body = "Slides are attached. Alex"
.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

This is really awesome. Just one suggestion as a final improvement: Is it possible to get rid of the double suffix? At the moment the excerpt presentation is named, e.g., "TestPresentation.pptx s_2_5_9.pptx" and it would be great to delete the .pptx in the middle of the name. I thought about deleting the last five letters of the old name, but it isn't a good idea in case one has to work with a very old presentation, which is .ppt (only 4). Is there any other wy to come to something like "TestPresentation s_2_5_9.pptx"?


(Different topic: For those who wonder about the order of the numbers in the name: It seems to me that it depends on your clicks and turns the order from last to first clicked. So when I first choose slide 22, then slide 6, then slide 18, I get "TestPresentation.pptx s_18_6_22.pptx". Means: One can have a correct order - depends on his clicks. And we only talk about the order in the name. The order in the excerpt presentation itself is correct. Awesome.)

Untested but should be close

Code:

---

Sub Attach_selected_slides()

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 = "john@pptalchemy.co.uk" 'Insert email address here!
.CC = ""
.Subject = strSubject
.Body = "Slides are attached. Alex"
.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

---

Tested. Works perfect. Thank you, John.

Hi,

I recently stumbled upon this thread when googling how to send a slide as as outlook attachment. Thank you for posting this! I am new to coding and it gets real frustrating. This is very much appreciated!

I have tried the code on powerpoint, and returns an error for me. I run the code on the editor and it works fine, but when I go the presentation and run it from there, it gives me:

"Run time error -214188160 (80048240)
Application unknown member. Invalid request. There is no currently active document window."

Please help. I copied and pasted the exact code from earlier posts and it still not working. I even googled the error number and it said there was a work around to it, but it is stll not working. https://support.microsoft.com/da-dk/...ntation-call-i

Here's the code:

Private Sub CommandButton1_Click()
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim otemp As Presentation
Dim opres As Presentation
Dim strName As String
Dim strSubject As String
If PowerPoint.Application.Version >= 9 Then
'window must be visible
PowerPoint.Application.Visible = msoTrue
End If
Dim L As Long
Dim raySlides() As Long
Set opres = ActivePresentation
Call zaptags(opres)
strSubject = opres.Name
strName = 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 = "your email"
.CC = ""
.Subject = " Shift Pass Down Email"
.Body = "Slides are attached. Thank You."
.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



Thanks in advance!

Sounds like you are trying to run the code from a slide SHOW?

You cannot do this as it is not possible to select the slides you want to attach.

Thanks John! Yes, I am trying to run the code from the slide show.

I tried playing with the code and I change some parts. I changed "activewindow.selection" to "activepresentation.slides.count".

It is attaching the Whole presentation to the email, but I just want 1 or 2 slides. When I try to direct the code to a specific slide, like "Slides(2)", an error pops up saying "object doesn't support property or method. run time error -438"

If this is not possible, thanks for the help! It is much appreciated!

strSubject= opres.Name
strName= opres.Name & " s_"
ReDimraySlides(1 To ActivePresentation.Slides.Count)
ForL = 1 To ActivePresentation.Slides.Count
ActivePresentation.Slides(L).Tags.Add"SELECTED", "YES"
IfL <> ActivePresentation.Slides.Count Then
strName= strName & ActivePresentation.Slides(L).SlideIndex & "_"
Else
strName= strName & ActivePresentation.Slides(L).SlideIndex
EndIf
NextL

Hi all,

Thank you for the wonderful code. I have tried it and it works perfectly

I do have two questions you might be able to help me with:

1. Is it possible to add a timestamp to the saved presentation? For instance send the slide with with the following name: Presentation 1s_5 29/01/2020 16:08?

2. This is more of a general question, how do you save the macro in your powerpoint so that you can always use it? If I run it now it works perfectly as long as i keep the presentations open. However when I start a new presentation the macro is gone. I have tried to save it as a ppt add in and add the macro to my ribbon bar but the macro doesn't work anymore.

Thanks very much in advance!

Gijs