VBA code to copy range of cells in mail body

[MohamedZedan]

Please i need some help as i have VBA code to send mail and i want to add to the mail body the cells range from A4 till S53, noting that this range contains some text and some charts

below is the VBA code i use to send the mail, Thanks for support in advance.



Sub Mail_ActiveSheet()


Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object






Set Sourcewb = ActiveWorkbook


'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook


'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsx": FileFormatNum = 51


End If
End With




' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False


'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & ""
TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yyyy")


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
Dim strbody As String


On Error Resume Next


strbody = _
_
"" & vbNewLine & _
"" & vbNewLine & _
"Regards,"


With OutMail

.To = Range("Z2")
.CC = ""
.BCC = ""
.Subject = "MTD Trend For " & Range("Z1")
.Body = strbody

'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False


On Error Resume Next
'Prepare the email
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)


On Error Resume Next


On Error GoTo 0


OutApp.Session.Logoff
Set OutMail = Nothing
Set OutApp = Nothing
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr


Set OutMail = Nothing
Set OutApp = Nothing

End With
End Sub