VBA Get better quality powerpoint slide into email body

picklechips

New Member
Joined
Jun 22, 2018
Messages
21
Hi I have a macro that creates an email and copies a powerpoint slide into the body of the email using the (.GetInspector.WordEditor) function.

However the quality of the slide is very blurry (even if I dont adjust the size of the slide). If I just do a manual screen clip of the slide its much better quality...


Was wondering if anyone knows how to make the quality better somehow?

Thanks in advance!
Pickles

Code:
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
    
 On Error GoTo ErrorHandler


    'Ratesheet pdf attachment
    MsgBox ("SELECT RATESHEET PDF - EMAIL ATTACHMENT")
    Ratesheetpdf = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf")
    
    'ppt slide attachment
    MsgBox ("SELECT POWERPOINT FILE - EMAIL BODY")
    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 email subject
    subj = Sheets(1).Range("c2")


    wb.Activate
    
    'add signature to email
    SigName = Sheets(1).Range("d2")
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & SigName & ".htm"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
   
    'Create email loop
    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
                With .InlineShapes(.InlineShapes.Count)
                .ScaleWidth = 150
                .ScaleHeight = 150
                End With
            End With
            .htmlbody = .htmlbody & "<br>" & "<span style='background:aqua;mso-highlight:aqua'>" & "If you wish to unsubscribe to this e-mail please respond with the subject Unsubscribe" & "</span>" & "<br>" & "<br>" & Signature
            
            .Attachments.Add Ratesheetpdf
            '.send
             End With
             
             'OutMail.Display
            'Dim wordDoc As Word.Document
            'Set wordDoc = OutMail.GetInspector.WordEditor
             'resize ppt slide
            'Dim shp As Object
            'For Each shp In wordDoc.InlineShapes
            'shp.ScaleWidth = 200
            'Next
  
    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


Exit Sub


ErrorHandler:
pptPres.Close
pptApp.Quit
MsgBox "Your stupid computer thinks the Powerpoint file is open by another user. Please try again." & vbNewLine & vbNewLine & Err.Description & Err.Number & Err.Source & Err.HelpFile & Err.HelpContext
OutMail.Close 1


End Sub
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Sorry just to add one more thing, frequently I get an error saying "This Method or Property is not available because the document is locked for editing" which hits at the code (.Application.Selection.TypeParagraph).

However, the powerpoint file is not a read-only file, is not open by anyone, and doesnt have any special permissions that im aware of. It works when I go through the code slowly line by line (using F8 in VBA editor) but when I try to run the macro in one shot I get that error. Any help would be greatly appreciated!
 
Upvote 0
There's an alternative method available for embedding an image within an email. I don't know whether it would improve the quality of the image, but it may be worth a try. Instead of copying and pasting the image into the email, this method first exports the slide into a temporary image file. Then, for each email created, the image file is attached to the email, and then embedded within its body using HTML code. Once all the emails have been created, the temporary image file is deleted. Here it is, with the changes/additions in red (note that I've added a space after each occurrence of the left angled bracket (<) to prevent the Board of interpretting the HTML code, so you'll need to remove those spaces from the code)...

Code:
Sub Emailtest()
    [COLOR=#ff0000]Dim TempFile As String[/COLOR]
    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
    
 On Error GoTo ErrorHandler


    'Ratesheet pdf attachment
    MsgBox ("SELECT RATESHEET PDF - EMAIL ATTACHMENT")
    Ratesheetpdf = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf")
    
    'ppt slide attachment
    MsgBox ("SELECT POWERPOINT FILE - EMAIL BODY")
    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 email subject
    subj = Sheets(1).Range("c2")


    wb.Activate
    
    'add signature to email
    SigName = Sheets(1).Range("d2")
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & SigName & ".htm"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    
[COLOR=#ff0000]    'Assign the file name for the temporary image file of the PowerPoint slide
    TempFile = "temp.jpg"
    
    'Export slide from PowerPoint presentation to temporary file
    pptSlide.Export Filename:=Environ("temp") & "\" & TempFile, FilterName:="JPG"[/COLOR]
   
    'Create email loop
    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
            .body = ""
[COLOR=#ff0000]            .Attachments.Add Environ("temp") & "\" & TempFile
            .HTMLBody = "< img src=""cid:" & TempFile & """ width=""150%"">"
[/COLOR][COLOR=#ff0000]            .HTMLBody = .HTMLBody & "< p>If you wish to unsubscribe to this e-mail please respond with the subject Unsubscribe.< /p>"[/COLOR]
[COLOR=#ff0000]            .HTMLBody = .HTMLBody & "< br>< br>" & Signature[/COLOR]
            .Attachments.Add Ratesheetpdf
            '.send
             End With
  
    Next i
    On Error GoTo 0
    
[COLOR=#ff0000]    'Delete the temporary image file of the PowerPoint slide
    Kill Environ("temp") & "\" & TempFile[/COLOR]


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


Exit Sub


ErrorHandler:
pptPres.Close
pptApp.Quit
MsgBox "Your stupid computer thinks the Powerpoint file is open by another user. Please try again." & vbNewLine & vbNewLine & Err.Description & Err.Number & Err.Source & Err.HelpFile & Err.HelpContext
OutMail.Close 1


End Sub

Note that you had .Display twice, so I removed one of them.

Hope this helps!
 
Last edited:
Upvote 0
Hi Domenic, sorry just got back from vacation.

I tried the code and it works like a charm! Really appreciate your help :)


Thanks,
Pickles
 
Upvote 0
That's great, I'm glad I could help! And thanks for the feedback!

Cheers!
 
Upvote 0

Forum statistics

Threads
1,223,993
Messages
6,175,838
Members
452,675
Latest member
duongtruc1610

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top