I'm attempting to generate an email in Outlook with the body as a range of cells and then paste a set of grouped charts below the cells in the same email body.
Currently, the script pastes the cells just fine - that's not a problem.
When the user runs the SendMail macro, the sheet unhides a set of data cells and the charts become visible (but screen update is False so the user doesn't see it), and then the sheet selects and copies the Group.
However, it doesn't paste this in a new line under the Range in Outlook.
I've noticed if I manually copy the Group and paste as an image in OUtlook, the body of the email seems completely formatted as cells and I have to set the image setting "through" for text and appear on the top layer, otherwise the image pastes inside a cell and the entire email body looks unappealing (and not what I'm shooting for).
Can anyone assist me with what I'm missing or doing wrong please? (plus - is there a way to block editing the cell content in outlook once pasted?)
Currently, the script pastes the cells just fine - that's not a problem.
When the user runs the SendMail macro, the sheet unhides a set of data cells and the charts become visible (but screen update is False so the user doesn't see it), and then the sheet selects and copies the Group.
However, it doesn't paste this in a new line under the Range in Outlook.
I've noticed if I manually copy the Group and paste as an image in OUtlook, the body of the email seems completely formatted as cells and I have to set the image setting "through" for text and appear on the top layer, otherwise the image pastes inside a cell and the entire email body looks unappealing (and not what I'm shooting for).
Can anyone assist me with what I'm missing or doing wrong please? (plus - is there a way to block editing the cell content in outlook once pasted?)
Code:
Sub SendMail() With ThisWorkbook.Sheets("DATS")
If WorksheetFunction.CountA(Sheets("DATS").Range("E32:E38")) = 0 Then
MsgBox "Please answer all questions in the Questionnaire Section of the DATS form.", vbCritical
Exit Sub
Else
MsgBox "Preparing DATS."
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
.EnableEvents = False
.ScreenUpdating = False
Sheet1.Unprotect Password:="****"
Rows("67:151").Select
Selection.EntireRow.Hidden = False
Set rng = Sheets("DATS").Range("B1:L65").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "Something went wrong." & _
vbNewLine & "Sometimes a bug occurs and you need to try again." & _
" Try sending the DATS again, please." & _
vbNewLine & vbNewLine & "If this *is* the second or third attempt, " & _
"please contact IT via the DATS Assist Icon." & _
vbNewLine & vbNewLine & "(NOTE: Help Requests take a screenshot " & _
"of your computer screen, so ensure the DATS form is maximized prior to sending a request.)", vbOKOnly
Rows("66:151").Select
Selection.EntireRow.Hidden = True
Sheet1.Protect Password:="****", UserInterFaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
ActiveSheet.Unprotect
Rows("66:133").Select
Selection.EntireRow.Hidden = False
Range("B1:L66", (Array("Group 6"))).Copy
End With
'Gets the data about which DAM to send the sheet based on the switch sets in DEV MODE
For Each Cell In Columns("Q").Cells.SpecialCells(xlCellTypeConstants)
If Cell.Value Like "?*@?*.?*" And _
LCase(Cells(Cell.Row, "R").Value) = "yes" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Cell.Value 'send to DAM from DIV cell linked in DEV MODE area
.CC = OutApp.Session.CurrentUser.Address 'CC self
.BCC = "" 'leave empty
.Subject = Range("G3").Value & " DATS Week ending: " & Range("K3").Value
.HTMLBody = "By submitting this time sheet, I attest the information is accurate and true to the best of my knowledge and ability." & RangetoHTML(rng) & vbNewLine & vbNewLine
ActiveSheet.Pictures.Paste.Select
.Signature = True
.Display 'DO NOT AUTOSEND - Sender needs to review email prior to sending
End With
On Error GoTo 0
'Hides the lower half of the METRICS cells to also hide GROUP 6 with DEV MODE AREA
With Application
Rows("66:151").Select
Selection.EntireRow.Hidden = True
Columns("N:W").Select
Selection.EntireColumn.Hidden = True
Sheet1.Protect Password:="****", UserInterFaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True
.EnableEvents = True
.ScreenUpdating = True
Range("C3").Select
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next
'Department reminders about sending schedules and the expense report.
End If
If Range("T9") = 4 Then
MsgBox "Cell Phone Expense reports are due. Send them to the manager as an individual email today." & vbNewLine & _
"The manager will not remind you or complete one for you.", vbExclamation + vbApplicationModal, "EXPENSE REPORT REMINDER"
ElseIf Range("T9") = 3 Then
MsgBox "Audit Schedules are due. Please prepare and submit your Audit Schedule by " & Range("J35"), vbInformation + vbApplicationModal, "AUDIT SCHEDULE DUE"
End If
End With
End Sub