Send email one by one

[Karthik Thandapani]

Hi,

Presently I've a VBA code with which I can able to trigger email to a group. However my requirement is to send email to the mentioned contacts one after another.

Can anyone modify the below VBA snippet and help. Please see the attached file.

Sub Assign()

    [E8] = Join(Application.Transpose(Range("N11:N" & Range("N11").End(xlDown).Row)), ";")


Dim Rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set Rng = Nothing
    On Error Resume Next
 
    Set Rng = Selection.SpecialCells(xlCellTypeVisible)
 
    Set Rng = Sheets("Sheet1").Range("E11").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    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)

    On Error Resume Next
    With OutMail
        .To = Range("E8").Value
        '.To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Notification from RA tool"
        .HTMLBody = RangetoHTML(Rng)
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
 
 
  'Call copymovedata
         
 
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

Thanks,
Karthik

 

[Deepak]

Why not try this!!!

.To = ""
.CC = ""
.BCC = Range("E8").Value

 

[vijay.vizzu]

Dear Karthik...

In your code, intially you are joining all the mail ids into one line, so that you can able to send mail to group. But if you want to send it one by one, then you need not to join the strings. Just put loop on that range, so that it create mail item one by one...

Please try this, mean while i will try to modify your code as per requirment

 

[vijay.vizzu]

I created two variables. Cell as range & EmailAddrRng as range. Please change the code as below.

Set EmailAddrRng = Range("N11:N" & Range("N11").End(xlDown).Row)
   
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
   
    On Error Resume Next
   
    For Each cell In EmailAddrRng
    With OutMail
        .To = cell.Value
        '.To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Notification from RA tool"
        .HTMLBody = RangetoHTML(Rng)
        .Display
    End With
    On Error GoTo 0
    Next cell

Sorry to say this.. i didn't try the above code. So please take backup of your original file. I hope it will work for you