• 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

    Hui...

  • 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

Status
Not open for further replies.

balabomma

New Member
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:
balabomma
Why You didn't continue with Your the 1st thread?
 
Status
Not open for further replies.
Back
Top