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]

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?

With the following macro, you'll notice that I've commented out 4 lines of code. If you want to add text to your email before copying/pasting the slide, you can un-comment those lines.

Option Explicit

Private Sub CommandButton1_Click()


    Dim olApp As Object
    Dim olMailItem As Object
    Dim olWordDoc As Object
    Dim objPres As Presentation
    Dim objSlide As Slide
    Dim strFullName As String


    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "PowerPoint Presentation", "*.pptx"
        .Title = "Open"
        If .Show <> -1 Then Exit Sub
        strFullName = .SelectedItems(1)
    End With
    
    Set objPres = Application.Presentations.Open(strFullName)
    Set objSlide = objPres.Slides(1)


    Set olApp = CreateObject("Outlook.Application")
    Set olMailItem = olApp.CreateItem(0)
    
    objSlide.Copy
    With olMailItem
        .Display
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .Body = ""
        Set olWordDoc = .GetInspector.WordEditor
        With olWordDoc
            '.Application.Selection.Text = "Please see the following..."
            '.Application.Selection.EndKey Unit:=6 'wdStory
            '.Application.Selection.TypeParagraph
            '.Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
     End With
     
     objPres.Close
     
    Set olApp = Nothing
    Set olMailItem = Nothing
    Set olWordDoc = Nothing
    Set objPres = Nothing
    Set objSlide = Nothing
        
End Sub

Hope this helps!

 

[YYAC0909]

Hi Domenic:

Thanks for your kindly instruction and code share. This code works and let me learn new things as well.

When I tried to improve the qualified images from email body, I refer to another code from you regarding html body and JPG.
However, the "file.jpg" transfer from a slide was not shown in the email body.
Would you please help to review the code that I modified below if available?

Sub email_to_ptt()

    Dim olApp As Object
    Dim olMailItem As Object
    Dim olWordDoc As Object
    Dim objPres As Presentation
    Dim objSlide As Slide
    Dim strFullName As String
    Dim TempFile As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "PowerPoint Presentation", "*.pptx"
        .Title = "Open"
        If .Show <> -1 Then Exit Sub
        strFullName = .SelectedItems(1)
    End With
    
    Set objPres = Application.Presentations.Open(strFullName)
    Set objSlide = objPres.Slides(1)
      
    TempFile = "temp.jpg"
    objSlide.Export FileName:=Environ("temp") & "\" & TempFile, FilterName:="JPG"
    
    Set olApp = CreateObject("Outlook.Application")
    Set olMailItem = olApp.CreateItem(0)
    
    With olMailItem
        .Display
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .Body = ""
        .HTMLBody = "< p>Hi All......< /p>"
        .HTMLBody = .HTMLBody & "< img src=""cid:" & TempFile & """ width=""150%"">"
     End With
     
     
     objPres.Close
     Kill Environ("temp") & "\" & TempFile
     
    Set olApp = Nothing
    Set olMailItem = Nothing
    Set objPres = Nothing
    Set objSlide = Nothing
    
End Sub

 

[Domenic]

With this method, you'll need to attach the image file to the email before assigning the HTML code to HTMLBody...

    With olMailItem
        .Display
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .Body = ""
[COLOR=#ff0000]        .Attachments.Add Environ("temp") & "\" & TempFile[/COLOR]
        .HTMLBody = "< p>Hi All......< /p>"
        .HTMLBody = .HTMLBody & "< img src=""cid:" & TempFile & """ width=""150%"">"
     End With

 

[YYAC0909]

Hi Domenic:

Really appreciate your kindly help and quickly response.
I did little modification on this code that I can successfully transfer a slide into a image and then insert this image into the email body by VBA.

I release this code for those who have same or similar purpose as me. Please refer to it below.

Sub onesilde_to_email()


    Dim olApp As Object
    Dim olMailItem As Object
    Dim olWordDoc As Object
    Dim objPres As Presentation
    Dim objSlide As Slide
    Dim strFullName As String
    Dim TempFile As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "PowerPoint Presentation", "*.pptm"
        .Title = "Open"
        If .Show <> -1 Then Exit Sub
        strFullName = .SelectedItems(1)
    End With
    
    Set objPres = Application.Presentations.Open(strFullName)
    Set objSlide = objPres.Slides(1)
      
    TempFile = "temp.jpg"
    objSlide.Export FileName:=Environ("temp") & "\" & TempFile, FilterName:="JPG"
    
    Set olApp = CreateObject("Outlook.Application")
    Set olMailItem = olApp.CreateItem(0)
    
    With olMailItem
        .Display
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .Body = ""
        .Attachments.Add Environ("temp") & "\" & TempFile
        .HTMLBody = "<p>Hi All:</p>" & "<p>Please refer to the summary of Mask Shop Tools Daily Slide WK below</p>"
        .HTMLBody = .HTMLBody & "<br><img src='cid:temp.jpg'" & "width='750'><br>" _
                              & "<br>Thanks & Regards, <br>Arron Chang</font></span>"
     End With
     
     
     objPres.Close
     Kill Environ("temp") & "\" & TempFile
     
    Set olApp = Nothing
    Set olMailItem = Nothing
    Set objPres = Nothing
    Set objSlide = Nothing
    
End Sub

Again really appreciate Domenic for helping to complete this case together.

 

[YYAC0909]

Sorry for chaotic typography and I sort of it again.

Sub onesilde_to_email()


    Dim olApp As Object
    Dim olMailItem As Object
    Dim objPres As Presentation
    Dim objSlide As Slide
    Dim strFullName As String
    Dim TempFile As String
  
    'Select slide.pptx or slide.pptm 
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "PowerPoint Presentation", "*.pptm"
        .Title = "Open"
        If .Show <> -1 Then Exit Sub
        strFullName = .SelectedItems(1)
    End With
    
    Set objPres = Application.Presentations.Open(strFullName)
    Set objSlide = objPres.Slides(1)
    
    'Output slide.pptx(pptm) to file.jpg
    TempFile = "temp.jpg"
    objSlide.Export FileName:=Environ("temp") & "\" & TempFile, FilterName:="JPG"
    
    'Open Outlook and insert image into email body
    Set olApp = CreateObject("Outlook.Application")
    Set olMailItem = olApp.CreateItem(0)
    
    With olMailItem
        .Display
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .Body = ""
        .Attachments.Add Environ("temp") & "\" & TempFile
        .HTMLBody = "Hi All:" & "Please refer to the image below"
        .HTMLBody = [COLOR=#574123].HTMLBody & "< img src=""cid:" & TempFile & """ width=""150%"">"[/COLOR]
     End With
     
     
     objPres.Close
     Kill Environ("temp") & "" & TempFile
     
    Set olApp = Nothing
    Set olMailItem = Nothing
    Set objPres = Nothing
    Set objSlide = Nothing
    
End Sub