VBA Copy a powerpoint slide into email body

[picklechips]

Hi all,

Im trying to create a VBA that inserts a powerpoint slide into the body of an email. Not sure if thats even possible...

If possible, it would open a prompt to me select the powerpoint file (using Application.GetOpenFilename maybe), then the macro would copy only the first powerpoint slide and paste it into the email body.


Below is the code I have so far which works in creating the email (creates multiple emails from loop if more than 100 email addresses are on my address list), only thing left is adding the one slide from a powerpoint file to the email body.

Thanks in advance!
Pickles

Option Explicit



Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object, ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function


Sub Emailtest()
    Dim SigString As String
    Dim SigName As String
    Dim Signature As String
  
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailTo As String
    Dim Ratesheetpdf As Variant
    Dim subj As String
    Dim body As String
    Dim LastRw As Long
    Dim i As Integer
    
    Ratesheetpdf = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf")
    
    Set OutApp = CreateObject("Outlook.Application")
    
    'Get the text that will go on the subject
    subj = Sheets(1).Range("b2")




   'Get the text that will go on the body
    body = ActiveWorkbook.Sheets(1).Range("c2")
    
    'add signature
    SigName = Sheets(1).Range("d2")
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & SigName & ".htm"
    MsgBox SigString
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    
    LastRw = Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 2 To LastRw Step 100


        EmailTo = Join(Application.Transpose(Sheets(1).Range("A" & i & ":A" & WorksheetFunction.Min(i + 99, LastRw)).Value), ";")


        Set OutMail = OutApp.CreateItem(0)
       With OutMail
            .To = EmailTo
            .CC = ""
            .BCC = ""
            .subject = subj
           '.body = body
            .htmlbody = body & vbNewLine & vbNewLine & Signature
            .Attachments.Add Ratesheetpdf
            .Display
            '.send
        End With
    
    Next i
    On Error GoTo 0


    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

 

[Domenic]

To prompt the user to select a PowerPoint file...

    Dim strFileName As String
    
    strFileName = Application.GetOpenFilename( _
        FileFilter:="PowerPoint Files (*.pptx), *.pptx", _
        Title:="Open", _
        ButtonText:="Open")
        
    If strFileName = "False" Then Exit Sub

To open the selected PowerPoint file, and assign the first slide to a variable, let's say pptSlide...

    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPres = pptApp.presentations.Open(strFileName)
    Set pptSlide = pptPres.slides(1)

To copy and paste the slide into the body of the email...

    With OutMail
        .Display
        .To = EmailTo
        .CC = ""
        .BCC = ""
        .Subject = subj
        .Body = Body
        pptSlide.Copy
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
        .HTMLBody = .HTMLBody & vbNewLine & vbNewLine & Signature
        '.Send
    End With

To close the presentation, and quit PowerPoint...

    pptPres.Close
    pptApp.Quit

Lastly, clear the PowerPoint objects from memory, along with your other objects...

    Set pptApp = Nothing
    Set pptPres = Nothing
    Set pptSlide = Nothing

Hope this helps!

 

[picklechips]

Hi Domenic, thank you for responding.

I updated my code, however i'm getting an error at the ".display". Maybe my OutMail variable shouldnt be set as an object? Sorry im still learning
The error is "Run-time error '91': Object variable or With block variable not set"

Below is my code with your suggestions added:

Thanks!
Pickles

Option Explicit

Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object, ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function


Sub Emailtest()
    Dim SigString As String
    Dim SigName As String
    Dim Signature As String
  
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailTo As String
    Dim Ratesheetpdf As Variant
    Dim subj As String
    Dim body As String
    Dim LastRw As Long
    Dim i As Integer
    Dim wb As Workbook
    
    Set wb = ThisWorkbook


    MsgBox ("Select Ratesheet PDF")
    Ratesheetpdf = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf")
    
        'ppt slide stuff
    MsgBox ("Select Powerpoint Email body File")
    Dim strFileName As String
    
    strFileName = Application.GetOpenFilename( _
        FileFilter:="PowerPoint Files (*.pptx), *.pptx", _
        Title:="Open", _
        ButtonText:="Open")
        
    If strFileName = "False" Then Exit Sub
    
      Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPres = pptApp.Presentations.Open(strFileName)
    Set pptSlide = pptPres.Slides(1)
    
    Set OutApp = CreateObject("Outlook.Application")
    
    'Get the text that will go on the subject
    subj = Sheets(1).Range("b2")




   'Get the text that will go on the body
    body = ActiveWorkbook.Sheets(1).Range("c2")
    
    wb.Activate
    
    'add signature
    SigName = Sheets(1).Range("d2")
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & SigName & ".htm"
    MsgBox SigString
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    
    LastRw = Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 2 To LastRw Step 100


        EmailTo = Join(Application.Transpose(Sheets(1).Range("A" & i & ":A" & WorksheetFunction.Min(i + 99, LastRw)).Value), ";")
    
       With OutMail
            .Display
            .To = EmailTo
            .CC = ""
            .BCC = ""
            .subject = subj
           '.body = body
            pptSlide.Copy
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
            .htmlbody = .htmlbody & pptSlide & vbNewLine & vbNewLine & Signature
            .Attachments.Add Ratesheetpdf
            '.send
        End With
    
    Next i
    On Error GoTo 0


    pptPres.Close
    pptApp.Quit
    Set pptApp = Nothing
    Set pptPres = Nothing
    Set pptSlide = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

 

[picklechips]

Sorry just noticed in the .htmlbody I had ".htmlbody = .htmlbody & pptSlide & vbNewLine & vbNewLine & Signature" instead should be ".htmlbody = .htmlbody & vbNewLine & vbNewLine & Signature"

I revised that but still get the same Run-time error.


THanks again,
Pickles

 

[picklechips]

Hey figured out that I accidently deleted "Set OutMail = OutApp.CreateItem(0)" from my code.

I fixed that however im now getting the error "Run-time error '4605': This method or property is not available becuase the document is locked for editing."

The error occurs at ".Application.Selection.TypeParagraph"

I dont believe my powerpoint file or excel macro file are locked... im able to type into them to change data.


Thanks,
Pickles

 

[picklechips]

Hi my apologies for all the replies lol

I tried running the macro again and it worked with no errors!


There is one last issue, I have my macro creating multiple emails with the next i function (depending on if there are more than 100 email addresses from my address list) and I want that one powerpoint slide pasted only once into each email body. However, its copying the powerpoint slide into the very 1st email multiple times. (ex. if I have 500 addresses it opens 5 emails, but copying the same powerpoint slide 5 times into the first email that was created).

Thank you!
Pickles

 

[picklechips]

Hey, figured it out! Had to add another ".display" after the email subject for it to select the new email I guess

Below code for anyone else trying to do similar projects.


Many thanks Domenic!!!
Pickles

Option Explicit



Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object, ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function


Sub Emailtest()
    Dim SigString As String
    Dim SigName As String
    Dim Signature As String
  
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailTo As String
    Dim Ratesheetpdf As Variant
    Dim subj As String
    Dim body As String
    Dim LastRw As Long
    Dim i As Integer
    Dim wb As Workbook
    
    Set wb = ThisWorkbook


    MsgBox ("Select Ratesheet PDF")
    Ratesheetpdf = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf")
    
        'ppt slide stuff
    MsgBox ("Select Powerpoint Email body File")
    Dim strFileName As String
    
    strFileName = Application.GetOpenFilename( _
        FileFilter:="PowerPoint Files (*.pptx), *.pptx", _
        Title:="Open", _
        ButtonText:="Open")
        
    If strFileName = "False" Then Exit Sub
    
      Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPres = pptApp.Presentations.Open(strFileName)
    Set pptSlide = pptPres.Slides(1)
    Set OutApp = CreateObject("Outlook.Application")
    
    'Get the text that will go on the subject
    subj = Sheets(1).Range("b2")




   'Get the text that will go on the body
    body = ActiveWorkbook.Sheets(1).Range("c2")
    
    wb.Activate
    
    'add signature
    SigName = Sheets(1).Range("d2")
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & SigName & ".htm"
    MsgBox SigString
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    
    LastRw = Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 2 To LastRw Step 100


        EmailTo = Join(Application.Transpose(Sheets(1).Range("A" & i & ":A" & WorksheetFunction.Min(i + 99, LastRw)).Value), ";")
    
       Set OutMail = OutApp.CreateItem(0)
       With OutMail
            .Display
            .To = EmailTo
            .CC = ""
            .BCC = ""
            .subject = subj
            .Display
           .body = ""
            pptSlide.Copy
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
            .htmlbody = .htmlbody & vbNewLine & vbNewLine & Signature
            .Attachments.Add Ratesheetpdf
            '.send
     
        End With
    
    Next i
    On Error GoTo 0


    pptPres.Close
    pptApp.Quit
    Set pptApp = Nothing
    Set pptPres = Nothing
    Set pptSlide = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

 

[YYAC0909]

Hi picklechip, I am also trying to insert a slide into the body of outlook via VBA.
I did some modification from your code, but I suffered the compile error: Method or data member not found on the strFileName.
Would you please help to give me some suggestions because I am a rookie of VBA? The code is below,
Thanks for you in advanced to answer my questions

Private Sub CommandButton1_Click()  
    Dim OutApp As Object
    Dim OutMail As Object
    
        'ppt slide stuff
    MsgBox ("Select Powerpoint Email body File")
    Dim strFileName As String
    
    strFileName = Application.GetOpenFilename("PowerPoint Files (*.pptx), *.pptx")
        
    If strFileName = "False" Then Exit Sub
    
    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPres = pptApp.Presentations.Open(strFileName)
    Set pptSlide = pptPres.Slides(1)
    Set OutApp = CreateObject("Outlook.Application")
    
       Set OutMail = OutApp.CreateItem(0)
       With OutMail
            .Display
            .To = ""
            .CC = ""
            .BCC = ""
            .Subject = ""
            .Display
           .body = ""
            pptSlide.Copy
           .htmlbody = .htmlbody & pptSlide
     
        End With
    
    On Error GoTo 0




    pptPres.Close
    pptApp.Quit
    Set pptApp = Nothing
    Set pptPres = Nothing
    Set pptSlide = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

 

[Domenic]

The code needs to run from within Excel, not Outlook or PowerPoint. Where are you placing your code?

 

[YYAC0909]

Hi Domenic

Thanks for your reply. Sorry for misunderstand this code. I placed this code in PowerPoint because I thought this code should be worked in the PowerPoint.
If possible, can you suggest how can I use this code in the PowerPoint to reach my goal? Or, can you recommend any related source that you know to me?