I managed to create the codes. Thanks again rollis for the link which was very helpful to prepare the codes
Sub DraftEmail()
Dim wsVR As Worksheet
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim wbVR As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
Dim Obs As String
Dim Cell As Range
Dim SRating As String
Dim MakeJPG As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set wbVR = ThisWorkbook
Set wsVR = wbVR.Worksheets("Visit Checklist")
wsVR.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End With
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Visit Checklist - store " & wsVR.Range("D5").Value
Select Case wsVR.Range("X20").Value
Case Is < 0.7
SRating = "Red"
Case Is > 0.85
SRating = "Green"
Case Else
SRating = "Amber"
End Select
If wsVR.Range("K83").Value = "No" Then SRating = "Red"
StrBody = "Dear " & wsVR.Range("G6").Value & "," & "<br>" & _
"We conducted a detailed LP review of " & wsVR.Range("D4").Value & " Store (" & wsVR.Range("D5").Value & ") " & _
"as on " & Format(wsVR.Range("D7").Value, "DD-MMM-YYYY") & ". " & "Based on the observations, the store is categorized as " & SRating & "." & "<br>" & _
"Please find the summary below and request your action plans and corrective measures within three working days." & "<br>" & "</br></br></br>"
Obs = "Important observations noted are as follows-" & "<br>" & "</br>"
'Create JPG file of the range
'Only enter the Sheet name and the range address
MakeJPG = CopyRangeToJPG("Visit Checklist", "P10:X24")
Dim flag As Boolean '<- added
Dim header As String '<- added
For Each Cell In wsVR.Range("L11:L83")
If Not IsEmpty(Cell) Then
If header <> Cell.Offset(0, -11).MergeArea.Cells(1, 1) Then flag = False 'detect if headerer has changed (new section) then reset flag
If flag = False Then 'detect if headerer has already been added to obs
Obs = Obs & "<br><b><u>" & Cell.Offset(0, -11).MergeArea.Cells(1, 1) & ":</b></u>" 'add headerer to obs
header = Cell.Offset(0, -11).MergeArea.Cells(1, 1) 'store headerer
flag = True 'set flag for headerer already added to obs
End If
Obs = Obs & "<br>" & Cell.Value & "</br>"
End If
Next Cell
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
'.to =
.CC = "anishms@msn.com"
.Subject = "LP Review | Store" & wsVR.Range("D5").Value & " (" & wsVR.Range("D4").Value & ") " & wsVR.Range("D7").Value
.Attachments.Add Destwb.FullName
.Attachments.Add MakeJPG, 1, 0
.HTMLBody = "<html><p>" & StrBody & "</p><img src=""cid:NamePicture.jpg"" width=616.5 height=275.25><p>" & Obs & "</p></html>"
.Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Kill MakeJPG
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
Dim PictureRange As Range
With ThisWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If
PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function
Reply With Quote
.
.