Convert excel report to PDF and display in email body

sxw54533

New Member
Joined
Aug 2, 2019
Messages
2
I've created a macro that will copy a set range in excel and paste into the body of an email as an image. I'm experiencing issues with the picture resolution when reading on a smart phone device. To improve the resolution I've set the macro to zoom in, copy and paste however this has had little effect on improving the resolution. I've tried to do a simple copy range and paste however the format moves around when pasted into an email.

I would like the report to export to a PDF and appear in the body as a PDF (not as an attachment). This will ensure the resolution remains clear when reading the format does not move around.

The macro will also auto save a copy of the report for future reference.

Can someone please take a look at my code and assist me with my issue?

Thanks

Rich (BB code):
Rich (BB code):
Private Sub EmailShiftReport_Click()
'This macro requires the code from
'to open Outlook

Dim oOutlookApp As Object
Dim oItem As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim xlRng As Range
Set xlRng = Range("$B$1:$V$110") 'The range to be copied
Dim s As String
Dim MyName As String, MyPath As String
MyName = ThisWorkbook.Name
MyPath = ThisWorkbook.Path

If Range("S3").Value = "12pm - 12am (PM Shift)" Then
s = "QLD_EOS_Report_" & Format(Now(), "dd_mmm_yy") & "_PM"
Else
s = "QLD_EOS_Report_" & Format(Now(), "dd_mmm_yy") & "_AM"
End If

ActiveWorkbook.SaveAs Filename:=MyPath & Application.PathSeparator & "Completed Reports" & Application.PathSeparator & s & ".xlsm"

ActiveWindow.Zoom = 400
xlRng.CopyPicture xlScreen, xlBitmap
ActiveWindow.Zoom = 100
Set oOutlookApp = OutlookApp() 
'to open Outlook, or it will not work correctly

'Create a new mailitem
Set oItem = oOutlookApp.createitem(0)
With oItem
.BodyFormat = 2 'html
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor 'access the message body for editing
Set oRng = wdDoc.Range
oRng.collapse 1 'set a range to the start of the message
'oRng.Text = "This is the message body before the Excel range:" & vbCr & vbCr
'Collapse the range to its end
oRng.collapse 0
'oRng.Text = vbCr & "This is the text after the Excel range."
'The range will be followed by the signature associated with the mail account
'collapse the range to its start
oRng.collapse 1
'paste the excel range in the message
oRng.Paste
'Address the message
.To = "email"
'Give it a title
.Subject = s
'attach the workbook
.attachments.Add ActiveWorkbook.FullName
'display the message - this line is required even if you then add the command to send the message
.Display
End With

'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set xlRng = Nothing
lbl_Exit:
Exit Sub
End Sub
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.

Forum statistics

Threads
1,213,530
Messages
6,114,163
Members
448,554
Latest member
Gleisner2

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