Consulting

Results 1 to 16 of 16

Thread: Macro to send a single slide as Outlook attachment

  1. #1
    VBAX Newbie
    Joined
    Apr 2016
    Posts
    5
    Location

    Question 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.

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    This is just code from the top of my head. It will need some error checks at least. Should get you going though.

    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
    Last edited by John Wilson; 04-29-2016 at 07:07 AM.
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    VBAX Newbie
    Joined
    Apr 2016
    Posts
    5
    Location
    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.
    Last edited by Albal; 04-29-2016 at 08:18 AM.

  4. #4
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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.
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  5. #5
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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.

    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  6. #6
    VBAX Newbie
    Joined
    Apr 2016
    Posts
    5
    Location
    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.

  7. #7
    VBAX Newbie
    Joined
    Apr 2016
    Posts
    5
    Location
    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.

  8. #8
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    Still untested top of head code but you should be able to do this

    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  9. #9
    VBAX Newbie
    Joined
    Apr 2016
    Posts
    5
    Location
    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

  10. #10
    VBAX Contributor
    Joined
    Apr 2015
    Location
    Germany
    Posts
    167
    Location
    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.)

  11. #11
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    Untested but should be close

    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  12. #12
    VBAX Contributor
    Joined
    Apr 2015
    Location
    Germany
    Posts
    167
    Location
    Tested. Works perfect. Thank you, John.

  13. #13
    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!

  14. #14
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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.
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  15. #15
    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

  16. #16
    VBAX Newbie
    Joined
    Jan 2020
    Posts
    1
    Location
    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •