Hi All
With the help of below code. I am able to solve the above issue. I am pasting it here and hope that it solve someone purpose with same query. You need to tweak the above macro little bit to meet the spec.
Option Explicit
Sub Preview()
SendEmail False
lbl_Exit:
Exit Sub
End Sub
Sub NoPreview()
SendEmail True
lbl_Exit:
Exit Sub
End Sub
Sub SendEmail(Optional bNoPreview As Boolean)
Dim iRec As Long
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim wdRng As Object
Dim rng As Range
Dim StrBody As String
Dim StrBody1 As String
Dim i As Long
Dim Subj As String
Dim FilePath As String
Dim EmailTo As String
Dim CCto As String
With Range("MergeData")
For i = 1 To .Rows.Count
Range("MergeRecord") = i - 1
Set rng = Nothing
Subj = .Cells(i, "A").Value
FilePath = .Cells(i, "B").Value
EmailTo = .Cells(i, "C").Value
CCto = .Cells(i, "D").Value
MsgBox Subj
Application.DisplayAlerts = False
Set rng = Sheets("Sheet2").Range("A1:E2").SpecialCells(xlCellTypeVisible)
rng.Copy
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
StrBody = "Dear Sir," & vbCr & vbCr & _
"Please be advised that we have given entry outstanding in our books." & vbCr & vbCr
StrBody1 = vbCr & vbCr & "We have attached copy document for your reference. Please could you have a look and provide your agreement and settlement date." & vbCr & vbCr & _
"Regards," & vbCr & vbCr
On Error Resume Next
With OutMail
.To = EmailTo
.CC = CCto
.BCC = ""
.Subject = Subj
.BodyFormat = 2
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set wdRng = wdDoc.Range(0, 0)
wdRng.Text = StrBody
wdRng.collapse 0
wdRng.Paste
wdRng.collapse 0
wdRng.Text = StrBody1
.Attachments.Add FilePath
.Display
If bNoPreview Then
.Send
End If
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
Sheets("Email_Sheet").Cells(1, "A").Value = "Outlook sent Time, Dynamic msg preview count = " & i + 1
Next i
End With
Cleanup:
Set OutApp = Nothing
Set OutMail = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set wdRng = Nothing
Set rng = Nothing
lbl_Exit:
Exit Sub
End Sub
