Send Html Email to a List from Excel Using Windows Live Mail

Hi,

I need to send a single email to each email address located in a list in column A of sheet1. (around 600 emails there).

Also I need is to copy range A1:H20 from sheet2 as HTML in the email body, and email Subject is located in sheet2 range J1
(Not any extra customization need it for the email).

I tried with Ron de Bruin's web page but I´m out of practice with vba and in a hurry.

I'm using excel 2010 and Windos Live Mail as email program. (This is my bigest problem as Ron`s solutions are mostly based in outlook.)

i really appreciate your help.

Regards,
Roberto.
LVL 5
PabilioAsked:
Who is Participating?
 
omgangIT ManagerCommented:
I agree, it looks correct.

I believe we need to add (try adding this one first)
objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1

and possibly (If the above doesn't work add this one)
objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True

OM Gang
0
 
omgangIT ManagerCommented:
You need a procedure to enumerate each of the email addresses in Sheet1 (column A) and call another procedure to generate an email message (not through Outlook) to each one.

I have the following VBA function in a test/dev Access db.  It should work just fine in Excel.  It uses CDO to send the email instead of automating the email client (e.g. Outlook, Windows Live Mail, etc.).

Function SendCDOEmail(strFrom As String, strTo As String, strSubj As String, strMsg As String, _
        blImportanceHigh As Boolean, blPriorityHigh As Boolean)
'send e-mail message to specified address(es)
On Error GoTo Err_SendCDOEmail
    
    Dim objMessage As Object, objCon As Object
    Dim strSMTPGateway As String
    
    strSMTPGateway = "smtpout.mydomain.com"  '<--- this is your outbound mail server
    
    Set objMessage = CreateObject("CDO.Message")
    Set objCon = CreateObject("CDO.Configuration")

        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPGateway
        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
        objCon.Fields.Update
    
    Set objMessage.Configuration = objCon
        objMessage.Subject = strSubj
        objMessage.From = strFrom

        objMessage.To = strTo

        'objMessage.TextBody = strMsg     '<--- this is for plain text message
        objMessage.HTMLBody = strMsg   '<--- this is for HTML message


            'check boolean variable to see if we should set importance High for this message
        If blImportanceHigh = True Then
            objMessage.Fields.Item("urn:schemas:mailheader:importance").Value = "high"
        End If
            'check boolean variable to see if we should set priority 1 for this message
        If blPriorityHigh = True Then
            objMessage.Fields.Item("urn:schemas:mailheader:priority").Value = 1
        End If
    
        objMessage.Fields.Update
        objMessage.Send
        
Exit_SendCDOEmail:
        'destroy object variables
    Set objMessage = Nothing
    Set objCon = Nothing
    Exit Function
    
Err_SendCDOEmail:
    MsgBox Err.Number & ", " & Err.Description, , "Error in function SendCDOEmail"
    Resume Exit_SendCDOEmail

End Function

Open in new window

0
 
PabilioAuthor Commented:
Hi  omgang,
Thank You very much for your feed back.
My mistake not to say in my question that for administrative reasons  I need to keep a copy of the emails  Sent to each recipient.

I believe this is not possible using CDO.

I Could spend days triying to call your function... Any help there is moré than welcome.

Regards
Roberto.
0
Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

 
omgangIT ManagerCommented:
I'm not positive on this but I'm thinking there's no automation for Windows Live Mail as there is with Outlook, i.e. it's not possible to instantiate Windows Live Mail via code and create messages and send them.   Additionally, there is limitations with Excel SendMail as outlined here http://www.rondebruin.nl/win/s1/div/mail4.htm
Will it suffice to bcc an internal address for the purpose of keeping a copy of each message sent?
OM Gang
0
 
PabilioAuthor Commented:
OM,
Yes it could work with a copy to myself in BCC.
Thank You for your time.
Roberto.
0
 
omgangIT ManagerCommented:
We need three pieces for your purposes.
1) enumerate the addresses in column A of sheet 1
2) convert the range of sheet 2 to html content
3) send an email


Try these
(paste into the ThisWorkbook module)

Option Explicit

Public Sub Draft_Message()
'code by OM Gang
On Error GoTo Err_Draft_Message

    Dim cell As Range, rng As Range
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim strAddy As String, strHTMLBody As String, strBCCAddy As String
    Dim strSubj As String
    
        'get message subject and message body from worksheet ranges
        'we only want to do this once
    Set ws1 = ActiveWorkbook.Sheets("Sheet1")
    Set ws2 = ActiveWorkbook.Sheets("Sheet2")
    
        'message subject
    strSubj = ws2.Range("J1").Value
    
        'message body
    Set rng = ws2.Range("A1:H20")

        'BCC address we want to use so we have a record of the message
    strBCCAddy = "myaddress@mydomain.com"
    
        'call Ron de Bruin's function to convert range to HTML
    strHTMLBody = RangetoHTML(rng)
        
        'enumerate addresses in column A of Sheet1
    For Each cell In ws1.Columns("A").Cells
            'don't process any blank cells and make sure the contents look like an email address
            'adapted from sample code from Ron de Bruin's site
        If cell.Value <> "" And cell.Value Like "?*@?*.?*" Then
            strAddy = cell.Value
            
                'call function to send email message
            Call SendCDOEmail("MyAddress@MyDomain.com", strAddy, strBCCAddy, strSubj, strHTMLBody, False, False)
        End If
    Next

Exit_Draft_Message:
        'destroy object variables
    Set ws2 = Nothing
    Set ws1 = Nothing
    Set rng = Nothing
    Set cell = Nothing
   Exit Sub

Err_Draft_Message:
   MsgBox Err.Number & " (" & Err.Description & ") in procedure Draft_Message of VBA Document Sheet1"
   Resume Exit_Draft_Message
   
End Sub



Function RangetoHTML(rng As Range)

'this function directly from Ron de Bruin's site

' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    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


Function SendCDOEmail(strFrom As String, strTo As String, strBCC As String, strSubj As String, strMsg As String, _
        blImportanceHigh As Boolean, blPriorityHigh As Boolean)

'this function from OM Gang

'send e-mail message to specified address(es)
On Error GoTo Err_SendCDOEmail
    
    Dim objMessage As Object, objCon As Object
    Dim strSMTPGateway As String
    
    strSMTPGateway = "MyOutboundMailServer.MyDomain.com"  '<--- this is your outbound mail server
    
    Set objMessage = CreateObject("CDO.Message")
    Set objCon = CreateObject("CDO.Configuration")

        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPGateway
        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
        objCon.Fields.Update
    
    Set objMessage.Configuration = objCon
        objMessage.Subject = strSubj
        objMessage.From = strFrom

        objMessage.To = strTo
        objMessage.BCC = "strBCC"

        'objMessage.TextBody = strMsg     '<--- this is for plain text message
        objMessage.HTMLBody = strMsg   '<--- this is for HTML message


            'check boolean variable to see if we should set importance High for this message
        If blImportanceHigh = True Then
            objMessage.Fields.Item("urn:schemas:mailheader:importance").Value = "high"
        End If
            'check boolean variable to see if we should set priority 1 for this message
        If blPriorityHigh = True Then
            objMessage.Fields.Item("urn:schemas:mailheader:priority").Value = 1
        End If
    
        objMessage.Fields.Update
        objMessage.Send
        
Exit_SendCDOEmail:
        'destroy object variables
    Set objMessage = Nothing
    Set objCon = Nothing
    Exit Function
    
Err_SendCDOEmail:
    MsgBox Err.Number & ", " & Err.Description, , "Error in function SendCDOEmail"
    Resume Exit_SendCDOEmail

End Function

Open in new window

0
 
PabilioAuthor Commented:
Hi OM,

I get the following error:
"-2147220977, Server rejected one or more email adress, Server Answer: 501<>: missin or malformed local part"

Probably I'm wrong, but, should I indicatein the code the user and password in order to use the SMTP Server ?

Thanks,
Roberto.
0
 
omgangIT ManagerCommented:
Check your Windows Live Mail setup; do you have 'my outgoing server requires authentication' checked?  If so, you'll need to provide credentials to the mail server.

      objCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = SMTPUserName
      objCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strPassWord

Where
SMTPUserName is a valid email user on your system
strPassWord is the password

Let me know if that resolves the issue.  I tested the code and it worked fine for me; my outbound server does not require authentication however.
OM Gang
0
 
PabilioAuthor Commented:
Hi OM,

Still having problems...

I tried with my gmail account to see if there is any strange situation with my outgoing mail server, but I'm having the following error too:

2147220978, Server rejected address from sender. Server answer: 530 5.5.1 http://support.google.com/mail.bin/answer.py?answer=14257 w5sm28032wiz.11 - gsmtp

I checked user and password and both are ok...

This is how I edited the function:

Function SendCDOEmail(strFrom As String, strTo As String, strBCC As String, strSubj As String, strMsg As String, _
        blImportanceHigh As Boolean, blPriorityHigh As Boolean)

'this function from OM Gang

'send e-mail message to specified address(es)
On Error GoTo Err_SendCDOEmail
   
    Dim objMessage As Object, objCon As Object
    Dim strSMTPGateway As String
    Dim strPassword As String
    Dim SMTPUserName As String
   
    strSMTPGateway = "smtp.gmail.com"  '<--- this is your outbound mail server
   
    Set objMessage = CreateObject("CDO.Message")
    Set objCon = CreateObject("CDO.Configuration")
    SMTPUserName = "XXXX@gmail.com"
    strPassword = "XXXXXXXX"

        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPGateway
        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = SMTPUserName
        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strPassword
        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
        objCon.Fields.Update
   
    Set objMessage.Configuration = objCon
        objMessage.Subject = strSubj
        objMessage.From = strFrom

        objMessage.To = strTo
        objMessage.BCC = "strBCC"

        'objMessage.TextBody = strMsg     '<--- this is for plain text message
        objMessage.HTMLBody = strMsg   '<--- this is for HTML message


            'check boolean variable to see if we should set importance High for this message
        If blImportanceHigh = True Then
            objMessage.Fields.Item("urn:schemas:mailheader:importance").Value = "high"
        End If
            'check boolean variable to see if we should set priority 1 for this message
        If blPriorityHigh = True Then
            objMessage.Fields.Item("urn:schemas:mailheader:priority").Value = 1
        End If
   
        objMessage.Fields.Update
        objMessage.Send
       
Exit_SendCDOEmail:
        'destroy object variables
    Set objMessage = Nothing
    Set objCon = Nothing
    Exit Function
   
Err_SendCDOEmail:
    MsgBox Err.Number & ", " & Err.Description, , "Error in function SendCDOEmail"
    Resume Exit_SendCDOEmail

End Function

Regards,
Roberto.
0
 
omgangIT ManagerCommented:
@Roberto,  the error message says the server doesn't like the sender email address.

note that when calling the function we pass in specific parameters

Function SendCDOEmail(strFrom As String, strTo As String, strBCC As String, strSubj As String, strMsg As String, _
         blImportanceHigh As Boolean, blPriorityHigh As Boolean)

The first parameter is strFrom.  This should be the From/Sender email address you wish to send the messages from, i.e. your gmail email address.

The function is called from the Draft_Message sub procedure here
Call SendCDOEmail("MyAddress@MyDomain.com", strAddy, strBCCAddy, strSubj, strHTMLBody, False, False)

What value are you using in place of "MyAddress@MyDomain.com"?
This is where you should be passing your gmail email address.

When I test it in my environment I do
Call SendCDOEmail("OMGang@EE.com", strAddy, strBCCAddy, strSubj, strHTMLBody, False, False)


OM Gang
0
 
PabilioAuthor Commented:
Hi OM,

I think I have it the right way:

Public Sub Draft_Message()
'code by OM Gang
On Error GoTo Err_Draft_Message

    Dim cell As Range, rng As Range
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim strAddy As String, strHTMLBody As String, strBCCAddy As String
    Dim strSubj As String
   
        'get message subject and message body from worksheet ranges
        'we only want to do this once
    Set ws1 = ActiveWorkbook.Sheets("Hoja1")
    Set ws2 = ActiveWorkbook.Sheets("Hoja2")
   
        'message subject
    strSubj = ws2.Range("J1").Value
   
        'message body
    Set rng = ws2.Range("A1:H20")

        'BCC address we want to use so we have a record of the message
    strBCCAddy = "cedronogal@gmail.com"
   
        'call Ron de Bruin's function to convert range to HTML
    strHTMLBody = RangetoHTML(rng)
       
        'enumerate addresses in column A of Sheet1
    For Each cell In ws1.Columns("A").Cells
            'don't process any blank cells and make sure the contents look like an email address
            'adapted from sample code from Ron de Bruin's site
        If cell.Value <> "" And cell.Value Like "?*@?*.?*" Then
            strAddy = cell.Value
           
                'call function to send email message
            Call SendCDOEmail("cedronogal@gmail.com", strAddy, strBCCAddy, strSubj, strHTMLBody, False, False)
        End If
    Next

Exit_Draft_Message:
        'destroy object variables
    Set ws2 = Nothing
    Set ws1 = Nothing
    Set rng = Nothing
    Set cell = Nothing
   Exit Sub

Err_Draft_Message:
   MsgBox Err.Number & " (" & Err.Description & ") in procedure Draft_Message of VBA Document Sheet1"
   Resume Exit_Draft_Message
   
End Sub

Please Let me know and thank you very much for your patience...
Roberto.
0
 
omgangIT ManagerCommented:
And, based upon this http://www.blueclaw-db.com/access_email_gmail.htm
we may need to change the smtpserverport from 25 to 587.
0
 
PabilioAuthor Commented:
Excellent OM,
This line:
objCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
And changing to port 587 does the trick for the gmail smtp server.
Thank You very much for your time and help.
Best regards,
Roberto.
0
 
omgangIT ManagerCommented:
Great work.  Sorry it took so long but I am unable to access web-based email from my work computer so was not able to test directly with Gmail.
Thanks!
OM Gang
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.