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