VBA Get better quality powerpoint slide into email body

[picklechips]

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

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

 

[picklechips]

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!

 

[Domenic]

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

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!

 

[picklechips]

Hi Domenic, sorry just got back from vacation.

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


Thanks,
Pickles

 

[Domenic]

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

Cheers!