Seeking assistance with the final step of a report I've generated!
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? I've pasted my current code below.
Thanks in advance!!!!
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() 'Use the function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'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
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? I've pasted my current code below.
Thanks in advance!!!!
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() 'Use the function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'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
