• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User


  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Send mails automatically copying a specific range from excel

Not open for further replies.


New Member
I am stuck in the below code. Please let me know the error in the 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
            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"
    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
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        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, _
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    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:


Excel Ninja
Why You didn't continue with Your the 1st thread?
Not open for further replies.