I am stuck in the below code. Please let me know the error in the code.
Code:
Option Explicit
Sub Mail_Automation_Display()
Application.ScreenUpdating = False
Dim rng As Range
Dim rng1 As Range
Dim oApplOL As Object
Dim oMiOL As Object
Dim lastRow As Long
Dim ws As Worksheet
Dim strMailSubject As String
Dim strMailMessage As String
Dim strMailMessage1 As String
Dim strMailMessage2 As String
Dim crtr As String
Dim i As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next
Set oApplOL = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set oApplOL = CreateObject("Outlook.Application")
End If
On Error GoTo 0
On Error Resume Next
For i = 1 To lastRow
crtr = ws.Cells(i, 4)
ActiveSheet.Range("A1:L" & i).AutoFilter Field:=4, Criteria1:=crtr
Set rng = ActiveWorkbook.Sheets("Sheet1").Range("A1:H" & lastRow).SpecialCells(xlCellTypeVisible)
If Trim(ws.Cells(i, 9).Value) Like "*?@?*.?*" Then
strMailSubject = ws.Cells(i, 11)
strMailMessage = "Hi " & ws.Cells(i, 4) & "<br>" & "<br>" & _
ws.Cells(i, 12) & "<br>" & "<br>"
strMailMessage1 = "<br>" & "<br>" & "Best Regards," & "<br>" & _
ws.Cells(i, 14)
strMailMessage2 = "<br>" & "<br>" & _
ws.Cells(i, 13)
Set oMiOL = oApplOL.CreateItem(0)
With oMiOL
.To = ws.Cells(i, 9)
.cc = ws.Cells(i, 10)
.Importance = 0
.Subject = strMailSubject
.HTMLBody = strMailMessage & RangetoHTML(rng) & strMailMessage2 & strMailMessage1
.ReadReceiptRequested = False
.send
End With
End If
Application.Wait (Now + TimeValue("0:00:02"))
Selection.AutoFilter = False
Next i
Set oApplOL = Nothing
Set oMiOL = Nothing
End Sub
'------------------------------------------------------------------------------------------------------
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Last edited by a moderator: