How to send email and add a range/current region as body

[bigMe]

dear friends,
need some help how to write the VBA code for my case.
I have a file with a several data, and i need to email each data (please see my image), i need to insert each data into the template email body and send it and repeat it to the next data until the last data.
Hope someone can help me with this, thank you.

best regards,
bigMe

 

[nguyendang]

Assume you have the following email template located in E:/Faktur Pajak Claim .msg, with %Data% as boilerplate text for data range:

The following macro will loop through cells in column E till last row, and if cell contains value (email address) then the macro will copy the current region based on that cell as picture and paste into the new email body (new email will be created based on the above email template).

Option Explicit

Public Sub CreateNewEmails()
    Dim strEmailTemplate As String
    'Location of email template
    strEmailTemplate = "E:\Faktur Pajak Claim .msg"
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.FileExists(strEmailTemplate) = False Then
        MsgBox "Email template not found. Please try again.", vbExclamation, "Error: Email Template Not Found"
        Exit Sub
    End If
    Dim objOlApp As Object, objMail As Object, objWE As Object
    On Error Resume Next
    ' Outlook must be opened
    Set objOlApp = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        MsgBox "Please open Outlook and try again.", vbExclamation, "Error: Outlook not launched"
        Exit Sub
    End If
    On Error GoTo 0
    Dim objEmailRange As Excel.Range
    Dim lngLastRow As Long
    Dim objSh As Excel.Worksheet
    Set objSh = Application.ActiveWorkbook.ActiveSheet
    lngLastRow = objSh.Cells(objSh.Rows.Count, 5).End(xlUp).Row
    If lngLastRow = 0 Then Exit Sub
    Set objEmailRange = objSh.Range("E1:E" & lngLastRow)
    Dim objDataRange As Excel.Range
    Dim objCell As Excel.Range
    Dim arrDataRange As Variant
    Dim objWdSel As Object
    For Each objCell In objEmailRange
        If IsEmpty(objCell.Value) = False Then
            Set objDataRange = objCell.CurrentRegion.Resize(objCell.CurrentRegion.Rows.Count, objCell.CurrentRegion.Columns.Count - 1)
            arrDataRange = objDataRange.Value
            objDataRange.CopyPicture
            Set objMail = objOlApp.CreateItemFromTemplate(strEmailTemplate)
            Set objWE = objMail.GetInspector.WordEditor
            With objMail
                .Display
                .To = objCell.Value
                .Subject = .Subject & arrDataRange(1, 1)
                Set objWdSel = objWE.Windows(1).Selection
                With objWdSel.Find
                    .Text = "%Data%"
                    .Wrap = 0
                    .Execute
                End With
                objWdSel.PasteSpecial DataType:=3
            End With
        End If
    Next
End Sub

 

[bigMe]

Dear Nguyendang,
Thank you very much for your response, your code works perfectly.

Best Regards,
bigMe