Help needed to complete VBA code for sending email

[Russel225]

Hi,

below is the code I'm using for sending email through excel.

Sub STRForm()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strbody As String
Dim srt As String
Dim strsubject As String

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
For Each cell In Range("H1:H20")
strbody = strbody & cell.Value & vbNewLine
Next

On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "G").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.CC = "person1@email.com;person2@email.com"
.Subject = Range("A2").value
.Body = strbody
.Attachments.Add ("C:\Users\Text.xls")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

I need to add two thing in above code

1. The code should take subject line from cell value which are in column A. for example If "G5" is Yes then subject should be from "A5" cell, If "G8" is Yes then subject should be from "A8" cell and so on....How can I achieve this.

2. My data has 8 column's and I want that information should be included in email. for example If G5 is Yes then values in A5, B5, C5, D5 and F5 should be included in email for that particular recipient.

Br

 

[rjwebgraphix]

First off, when posting code, PLEASE please please please please use code tags. It makes it easier to copy over to the editor without having to reformat all the code to see what its doing.

I don't see a need for trapping errors in this case. Instead, test for potential errors and do something with them. It wasn't until I took out the "On error goto" line that I could find the errors and fix them.

One last thing before getting into code. The means of testing email addresses is Inadequate. Far too many more variations, plus gives you no reason why a failure would exist. Here's a function I picked up that would be perfect for your application. I didn't write the function, so give me no credit for it. All credits left in tact.

Private Function IsValidEmailAddress(ByVal sEmail As String, _
                                     Optional ByRef sReason As String) As Boolean
   '-- http://www.vbforums.com/showthread.php?513535-Email-Address-Format-Validation&p=3166934#post3166934
   '-- Coded by Hoang Nguyen (anhn @ VBForums)
   '-- There may be some missing conditions
   '   or I am not sure whether they are valid or not.
   '-- Not validating format like:  peter@[10.11.12.13]
   '   or email address formats with explicit source route.
   '-- PLEASE USE WITH CAUTIONS, MODIFY IT AS YOU NEED
   '-------------------------------------------------------
  'Made by alell: Changes for Multi-reason function for clumsy end-user ;-))
  
  sEmail = LCase(Trim(sEmail))
  'IsValidEMailAddress = False
  If Len(sEmail) < 7 Then '-- Is a@b.com a valid email address?
     sReason = "> Too short" & vbCrLf
  End If
  
  If sEmail Like "*[!0-9a-z@._+-]*" Then
     '-- not sure about these characters: ! $ & ` ' * / \ = ? ^ | # % { } ~
     '   if required, add in to the above string after letter z and before the last hyphen -
     sReason = sReason & "> Invalid character" & vbCrLf
  End If
  
  If Not sEmail Like "*@*.*" Then
     sReason = sReason & "> Missing the @ or ." & vbCrLf
  End If
  If sEmail Like "*@*@*" Then
     sReason = sReason & "> Too many @" & vbCrLf
  End If
  'Added by alell to avoid validation of "aaaa.bbbb.com"
  If sEmail Like "*.*.*" Then
     sReason = sReason & "> Too many ." & vbCrLf
  End If
  If sEmail Like "[@.]*" Or sEmail Like "*[@.]" _
     Or sEmail Like "*..*" Or Not sEmail Like "?*@?*.*?" Then
     sReason = sReason & "> Invalid format" & vbCrLf
  End If
  
  Dim n As Integer
  If InStrRev(sEmail, ".") > 0 Then
    n = Len(sEmail) - InStrRev(sEmail, ".")
    If n > 3 Then
       sReason = sReason & "> Suffix too long"
    ElseIf n < 2 Then
       sReason = sReason & "> Suffix too short"
    Else
      If sReason <> "" Then Exit Function
       sReason = Empty
       IsValidEmailAddress = True
    End If
  End If
    
End Function

Here's how I modified your code based on the 2 things you said you need.

1. Subject comes Column A of the row
2. Moved subject body to build the body within the main loop. (it was outside of the main loop) This is assuming that all you need is the data in the first 5 columns of the row and not something outside of the this range as explained.
3. Changed variable name from cell to cel for no other reason that its not a good idea to use cell or row or column as variables.

What was done that wasn't asked for:
1. Using the above function to test an email address and provide back a reason for failure.
2. If the the email address fails, it will pop up a box to tell you the reason it failed, however, if I were you, I would expand that to cover all email failing addresses at the same time (like using a collection or array) rather than at the time of failure or at least point you to the ones that fail. It could get annoying if you have 40 emails to send out and 20 of them have bad email addresses.
This is a good starting point though.

Here you go, if you need something else, feel free.

Sub STRForm()
Dim OutApp As Object
Dim OutMail As Object
Dim cel As Range
Dim strbody As String
Dim srt As String
Dim strsubject As String

'added variables
Dim i As Long
Dim GoodEmlAddr As Boolean
Dim BadEmlReason As String

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

'On Error GoTo cleanup
For Each cel In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    'added function to test for valid email address
    GoodEmlAddr = IsValidEmailAddress(cel.Value, BadEmlReason)
    If GoodEmlAddr = True Then
        If LCase(Cells(cel.Row, "G").Value) = "yes" Then
            strsubject = Cells(cel.Row, "A").Value
            For i = 1 To 6
                strbody = strbody & Cells(cel.Row, i).Value & vbNewLine
            Next i
        End If

        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = cel.Value
            .CC = "person1@email.com;person2@email.com"
            .Subject = strsubject
            .Body = strbody
            .Attachments.Add ("C:\Users\Text.xls")
            .Display
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    Else
        MsgBox "Email address invalid:" & Chr(10) & Chr(10) & BadEmlReason, vbCritical
    End If
Next cel

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[Russel225]

Hi rjwebgraphix,

First Thank you for your time and Energy.

This code giving me error Email address invalid though I have valid Email Addresses in Column B.

One more thing I was taking Body of the email from the code

For Each cell In Range("H1:H20")
strbody = strbody & cell.Value & vbNewLine
Next

My email format is same for every email ID. let me explain... If G2 is Yes then in my body part of email
Is

Some Fixed Text
....................
....................

After That below information for that particular Email Id

Column A Heading	value in column A2
Column B Heading	value in column B2
Column C Heading	value in column C2
Column D Heading	value in column D2
Column E Heading	value in column E2

<tbody>
</tbody>

Some Fixed Text
...........
...........

I am attaching Excel file with the same format As I am using by removing original data.

Please find the link

https://docs.google.com/file/d/0B1IuDWb4Rm9pYk9TbWwtS1dOVlk/edit?usp=sharing

Sorry for trouble, since I don't know how to use this site feature's while posting, will learn soon.

BR

 

[rjwebgraphix]

Try this one. It's the Function and the code in one. There was a bug in the function from yesterday that I did not notice. Also, with your original code it would look at the header row looking for an email address also, so would crash. Changed to start at row 2 to the last row of column B.

I also took the liberty of trapping bad email addresses for you. It'll just display one msgbox in the end to show you all that failed.

Now msgbox does have a limit, so if there are 1000 bad email addresses, it'll get to the point where it won't display any more, but a simple at a glance thing this should work nicely.

Private Function IsValidEmailAddress(ByVal sEmail As String, _
                                     Optional ByRef sReason As String) As Boolean
   ' http://www.vbforums.com/showthread.php?513535-Email-Address-Format-Validation&p=3166934#post3166934
   '-- Coded by Hoang Nguyen (anhn @ VBForums)
   '-- There may be some missing conditions
   '   or I am not sure whether they are valid or not.
   '-- Not validating format like:  peter@[10.11.12.13]
   '   or email address formats with explicit source route.
   '-- PLEASE USE WITH CAUTIONS, MODIFY IT AS YOU NEED
   '-------------------------------------------------------
   sEmail = LCase(Trim(sEmail))
   'IsValidEMailAddress = False
   If Len(sEmail) < 7 Then '-- Is a@b.com a valid email address?
      sReason = "Too short"
   ElseIf sEmail Like "*[!0-9a-z@._+-]*" Then
      '-- not sure about these characters: ! $ & ` ' * / \ = ? ^ | # % { } ~
      '   if required, add in to the above string after letter z and before the last hyphen -
      sReason = "Invalid character"
   ElseIf Not sEmail Like "*@*.*" Then
      sReason = "Missing the @ or ."
   ElseIf sEmail Like "*@*@*" Then
      sReason = "Too many @"
   ElseIf sEmail Like "[@.]*" Or sEmail Like "*[@.]" _
      Or sEmail Like "*..*" Or Not sEmail Like "?*@?*.*?" Then
      sReason = "Invalid format"
   Else
      Dim n As Integer
      n = Len(sEmail) - InStrRev(sEmail, ".")
      If n > 3 Then
         sReason = "Suffix too long"
      ElseIf n < 2 Then
         sReason = "Suffix too short"
      Else
         sReason = Empty
         IsValidEmailAddress = True
      End If
   End If
End Function
Sub STRForm()
Dim OutApp As Object
Dim OutMail As Object
Dim cel As Range
Dim strbody As String
Dim srt As String
Dim strsubject As String

'added variables
Dim i As Long
Dim GoodEmlAddr As Boolean
Dim BadEmlReason As String
Dim lr As Long
lr = Range("B" & Rows.Count).End(xlUp).Row
Dim BadEmlResults As String
Dim BadEmlBoo As Boolean

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

For Each cel In Range("B2", "B" & lr)
    'added function to test for valid email address
    GoodEmlAddr = IsValidEmailAddress(cel.Value, BadEmlReason)
    If GoodEmlAddr = True Then
        If LCase(Cells(cel.Row, "G").Value) = "yes" Then
            strsubject = Cells(cel.Row, "A").Value
            For i = 1 To 20
                strbody = strbody & Cells(i, "H").Value & vbNewLine
            Next i
            For i = 1 To 6
                strbody = strbody & Cells(cel.Row, i).Value & vbNewLine
            Next i
            
        End If
        
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .to = cel.Value
            '.CC = "person1@email.com;person2@email.com"
            .Subject = strsubject
            .Body = strbody
            '.Attachments.Add ("C:\Users\Text.xls")
            .Display
            'To send instead of display, comment out Display and uncomment send
            '.Send
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    Else
        BadEmlResults = BadEmlResults & "Row: " & cel.Row & " - Email Address: " & cel.Value & " - Reason: " & BadEmlReason & vbLf
        BadEmlBoo = True
    End If
Next cel

Set OutApp = Nothing
Application.ScreenUpdating = True

If BadEmlBoo = True Then
    MsgBox "Emails not sent for:" & vbLf & vbLf & BadEmlResults, vbInformation
Else
    MsgBox "All emails sent"
End If

End Sub

 

[Russel225]

Hi rjwebgraphix,

This code giving me weird result, this code attaches previous email ID body to next email ID body. For example Ist email Is ok, in second email this code also attaches previous email body, so two email body in next email..

Is there any way I can get below code information in format shown below

For i = 1 To 10
strbody = strbody & Cells(i, "H").Value & vbNewLine
Next i For i = 1 To 6
strbody = strbody & Cells(cel.Row, i).Value & vbNewLine Next i
For i = 10 To 15
strbody = strbody & Cells(i, "H").Value & vbNewLine
Next i

Text from Ist for loop

then this table format from next for loop(as shown in earlier reply) may be through some html coding

<tbody>
</tbody>

Then text from next for loop.

Br//

 

[Russel225]

Hi, rjwebgraphix

Thanks for your support, [URL="http://www.mrexcel.com/forum/members/rjwebgraphix.html"] got what I needed.
[/URL]

 

[rjwebgraphix]

Been a busy last few days at work, so I haven't been able to get on till today, but glad you got it sorted.