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