Need help to send email from excel

[jawahars]

Hi

I have a excel file two sheet

Email id is sheet one which contains email is based on issue like in cell A1 is the issue b3 is the email Id

Email body is sheet two

In which data is there from coloum a to q column Q as the issue category

I need to send email with data available in coloum a to p

Subject is the issue category + I have to add the date of today

After each issue category one row is blank and the heading is add in next row

Like wise I have like 40 to 50 issue category in excel and there email I’d

Please help me in macro coding

[HansV]

Could you post a sample workbook with some dummy data?

[jawahars]

Hi Hans

Please find sample dump

[HansV]

I'll look at it, but it is a big request, so it might take a while.

[HansV]

The following code has been adapted from Mail Range/Selection in the body of the mail. All credit goes to Ron de Bruin.
The code works best if Outlook has already been started when you run the macro.

Code: Select all

Sub SendMessages()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim wsh1 As Worksheet
    Dim wsh2 As Worksheet
    Dim r As Long
    Dim m As Long
    Dim strSubject As String
    Dim strTo As String
    Dim cel As Range
    Dim r1 As Long
    Dim r2 As Long
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set wsh1 = Worksheets("Email ID")
    Set wsh2 = Worksheets("Email")
    Set cel = wsh2.Range("A1")
    m = wsh1.Range("A" & wsh1.Rows.Count).End(xlUp).Row
    For r = 2 To m Step 3
        strSubject = wsh1.Range("A" & r).Value & " " & Format(Date, "dd/mm/yyyy")
        strTo = wsh1.Range("B" & r + 1).Value
        r1 = cel.Row
        Set cel = cel.End(xlDown)
        r2 = cel.Row
        Set cel = cel.End(xlDown)
        Set rng = wsh2.Range("A" & r1 & ":P" & r2)
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = strTo
            .Subject = strSubject
            .HTMLBody = RangetoHTML(rng)
            .Display ' or .Send to send the message immediately
        End With
        On Error GoTo 0
    Next r

    Set OutMail = Nothing
    Set OutApp = Nothing

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

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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"

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

[Doc.AElstein]

Hi jawahars
Here is an alternative that does not need Outlook. It does not use anything to do with Outlook, ( I think)
I have used the range stuff from Han’s code.
But it sends direct using VBA
( So you have no chance to display the Messages. They are sent once you run the code )

You will need to add your Email address and your Email Password.
You may need to adjust the “smtpserver” – I put some alternatives in the ‘Comments

I tested it using your data:_..
jawaharsData.JPG : https://imgur.com/zYwfK9t" onclick="window.open(this.href);return false;
_.. with a couple of my Email addresses:
My2Emails.JPG : https://imgur.com/swon9zc" onclick="window.open(this.href);return false;

The Emails came on:
ArrivedAtTelekom.JPG : https://imgur.com/6xPAV6j" onclick="window.open(this.href);return false;
ArrivedAtGMail.JPG : https://imgur.com/7gZ44Wm" onclick="window.open(this.href);return false;

Alan

Code: Select all

Sub jawaharsEMailFinal_1() 'http://www.eileenslounge.com/viewtopic.php?f=27&t=29556#p228691
'For info see:  http://www.excelfox.com/forum/showthread.php/2233-Urgent-support-needed-Multiple-emails-multiple-Excel-workbooks-at-once#post10519
'Don't forget to copy the function ProTbl in the module, and add your EMail Address and Password
'Working at my end With my With End With Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups)
' From here Han's range stuff             -**
Dim wsh1 As Worksheet, wsh2 As Worksheet: Set wsh1 = Worksheets("Email ID"): Set wsh2 = Worksheets("Email")
Dim cel As Range: Set cel = wsh2.Range("A1")
Dim r, m As Long: Let m = wsh1.Range("A" & wsh1.Rows.Count).End(xlUp).Row
    For r = 2 To m Step 3 ' Main loop for each EMail ==========
    Dim r1 As Long: Let r1 = cel.Row
     Set cel = cel.End(xlDown)
    Dim r2 As Long: Let r2 = cel.Row
    Dim rngArr() As Variant: Let rngArr() = wsh2.Range("A" & r1 & ":P" & r2).Value ' Han's Range select as Array -**
        With CreateObject("CDO.Message") ' -Linking Cods Wollups--------
        Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/"
         .Configuration(LCD_CW & "smtpusessl") = True '
         .Configuration(LCD_CW & "smtpauthenticate") = 1  '
        '  ' Sever info
         .Configuration(LCD_CW & "smtpserver") = "smtp.gmail.com" ' "securesmtp.t-online.de" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com"  "smtp-mail.outlook.com" "smtp.live.com"  "securesmtp.t-online.de"
        '  The mechanism to use to send messages.
         .Configuration(LCD_CW & "sendusing") = 2  '  Based on the LCD_OLE Data Base of type DBTYPE_I4
         .Configuration(LCD_CW & "smtpserverport") = 25 ' 465 or 25 for t-online.de 'or 587 'or 25
        '
         .Configuration(LCD_CW & "sendusername") = "YourEMailAddress"
         .Configuration(LCD_CW & "sendpassword") = "YourEMailPassword"
        ' Optional - How long to try
         .Configuration(LCD_CW & "smtpconnectiontimeout") = 30 '
        ' Intraction protocol is Set/ Updated
         .Configuration.Fields.Update '
        'End With ' ----------------------      my Created  LCDCW Library
        'With ' --- ' Data to be sent------     my Created  LCDCW Library
         Dim strHTML As String: Let strHTML = ProTble(rngArr()) ' Let strHTML = RangetoHTML(rng)
        '         Dim Highway1 As Long: Let Highway1 = FreeFile(0) '
        '          Open ThisWorkbook.Path & "\" & "jawaharse.txt" For Output As #Highway1 '
        '          Print #Highway1, strHTML
        '          Close #Highway1
        .To = wsh1.Range("B" & r + 1).Value ' 
        .cc = ""
        .BCC = ""
        .from = """jawahars"" <YourEMailAddresseOrAnyCrap>"
        .Subject = wsh1.Range("A" & r).Value & " " & Format(Date, "dd/mm/yyyy")
        .HTMLBody = strHTML
        '        .AddAttachment ThisWorkbook.Path & "\jawaharse.txt"
        .Send ' Do it
        End With ' CreateObject("CDO.Message") -----my Created  LCDCW Library
     Set cel = cel.End(xlDown) ' To next range top left
     Let strHTML = ""
    Next r '=====End Main Loop =========================================
End Sub


Function ProTble(ByRef arrNuts() As Variant) As String
' Table start
 Let ProTble = _
"<table width=1089>" & vbCrLf & _
"<col width=56>" & vbCrLf & _
"<col width=51>" & vbCrLf & _
"<col width=71>" & vbCrLf & _
"<col width=50>" & vbCrLf & _
"<col width=54>" & vbCrLf & _
"<col width=56>" & vbCrLf & _
"<col width=109>" & vbCrLf & _
"<col width=56>" & vbCrLf & _
"<col width=86>" & vbCrLf & _
"<col width=85>" & vbCrLf & _
"<col width=76>" & vbCrLf & _
"<col width=59>" & vbCrLf & _
"<col width=74>" & vbCrLf & _
"<col width=72>" & vbCrLf & _
"<col width=39>" & vbCrLf & _
"<col width=95>" & vbCrLf & vbCrLf
Dim iCnt As Long, jCnt As Long ' data "rows" , "columns"
    For jCnt = 1 To UBound(arrNuts(), 1)
    Dim LisRoe As String
     Let LisRoe = LisRoe & "<tr height=16>" & vbCrLf
        For iCnt = 1 To UBound(arrNuts(), 2)
         Let LisRoe = LisRoe & "<td>" & arrNuts(jCnt, iCnt) & "</td>" & vbCrLf
        Next iCnt
     Let LisRoe = LisRoe & "</tr>" & vbCrLf & vbCrLf
     Let ProTble = ProTble & LisRoe
     Let LisRoe = ""
    Next jCnt
 Let ProTble = ProTble & "</table>" ' table end
End Function

( Edit here is another link to the stuff from Ronny https://msdn.microsoft.com/en-us/library/ff519602(v=office.11).aspx#odc_office_UseExcelObjectModeltoSendMailPart2_IntroductiontoSendingEMail )

[Rudi]

Wow! That code looks scary!

[Doc.AElstein]

Wow! That code looks scary!

Hello Rudi
You don’t mean mine do you .. ?? definitely one of my milder attempts …very monotone, - the original is slightly prettier in the color tones at pastebin
https://pastebin.com/HUuXSvsR" onclick="window.open(this.href);return false;
http://www.excelfox.com/forum/showthread.php/2 ... #post10516
.. the one I use myself for my own stuff would need about 20 posts to fit in here :-)

That “CDO / LCDCW Library way” to send Emails seems very simple and reliable - I use it to send stuff directly from Excel and Word quite a lot. . – I gave up with Outlook – I could never figure out what all that was about – unless you have Outlook set up and running then you can’t use a code like Han’s.
.. I don’t use the strange “Excel Range Publish” stuff either for my HTML tables – I couldn’t figure out what that was all about either ( and you end up with a massive HTML string that you only need a small part of) , - Instead I found it is fairly easy to make your own HTML table strings from an Excel range, so I do that instead.
(.. currently I think I am the only one that can send pretty coloured tables in a German Telekom EMail – there is something wrong with their HTML and all the colors get messed up or turn black and white instead. I did a simple MOD in the HTML tables strings that I make and send .. and I was able to get the colours to work properly )
Alan

[Rudi]

... the original is slightly prettier in the color tones at pastebin...

Colour makes it prettier, but its still scary, like a Venus Flytrap!

[jawahars]

Hi Hans,
I used your code but I have one issue here
In email I’d sheet I have like 300 + issue category and it’s distribution
list
In the email sheet today I had 50 issue category type
But email is been sent to all the 300 + issue category in which I had only
50 valid email all other are blank emails
Please help to fix

[HansV]

In your sample workbook, the categories on the Email ID sheet correspond exactly to those on the Email sheet.
Is the real situation different? Then you should provide a sample workbook that reflects this. I cannot provide code for a situation that I don't know.

[jawahars]

Hi Hans,

Attached is the template as requested

In email sheet column Q is the key work for the email ID sheet DISTRIBUTION LIST

IN EMAIL I’d sheet we have more issue category and it distribution list

Based on the email sheet issue category distribution list as to be selected and only for the actual issue available in email sheet as to be send

Please help

[HansV]

Thanks. You see how important it is to provide relevant information; there was no way I could have guessed this from the first sample workbook.

Here is a modified version of the SendMessages macro. The RangeToHTML function remains the same, you still need it.

Code: Select all

Sub SendMessages()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim wsh1 As Worksheet
    Dim wsh2 As Worksheet
    Dim strCategory As String
    Dim strSubject As String
    Dim strTo As String
    Dim cel As Range
    Dim r1 As Long
    Dim r2 As Long
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set wsh1 = Worksheets("Email ID")
    Set wsh2 = Worksheets("Email")
    Set cel = wsh2.Range("A1")
    Do
        r1 = cel.Row
        strCategory = cel.Offset(1, 16).Value
        Set cel = cel.End(xlDown)
        r2 = cel.Row
        strSubject = strCategory & " " & Format(Date, "dd/mm/yyyy")
        strTo = wsh1.Range("A:A").Find(What:=strCategory, LookAt:=xlWhole).Offset(1, 1).Value
        Set rng = wsh2.Range("A" & r1 & ":P" & r2)
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = strTo
            .Subject = strSubject
            .HTMLBody = RangetoHTML(rng)
            .Display ' or .Send to send the message immediately
        End With
        On Error GoTo 0
        Set cel = cel.End(xlDown)
    Loop Until cel.Row = wsh2.Rows.Count

    Set OutMail = Nothing
    Set OutApp = Nothing

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

[jawahars]

Thanks a lot Hans you are always best