CDO Email, specific cells in the body

[Oximoxi]

Hey all!

Is it possible to send email through SMTP server using CDO (no Outlook!) and insert specific cells in to the body of the email? I have functioning macro for sending emails, but I strugle with the body content. I would like to insert specific region in to the body of the email. Cells from columns A-N and from the last filled row. Is it possible? I can't figure out how to do it.

Thanks, Oxi.

 

[paulxmw]

Hi I Found this on Ron De Bruin's web site, it should get you going
1) Open a new workbook
2) Alt F11 (to open the VBA editor)
3) Insert>Module
4) Paste the code in this module
5) Make your changes
6) Alt q to go back to Excel

When you use Alt F8 you can select the macro and press Run.
Now wait a moment and see if you receive the mail in your inbox. Sub CDO_Mail_Small_Text()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
' .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Fill in your SMTP server here"
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
' End With

strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"

With iMsg
Set .Configuration = iConf
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.From = """Ron"" <ron@something.nl>"
.Subject = "Important message"
.TextBody = strbody
.Send
End With

Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Sub Note: If you get this error : The transport failed to connect to the server
then try to change the SMTP port from 25 to 465

 

[Oximoxi]

Hi,

I know this Ron's code. But I still can't figure out how to insert last row of the table in to the body. Now, my macro sends email when new record is made. But it would be great, if I could insert that record (last filled row of the table) in to the body of the email.

 

[paulxmw]

You could try inserting after the STR Body, this sorts the emails by email address currently set ti Column B and copies a range of cells from the rest of the sheet set to A up to H

'Set filter sheet, you can also use Sheets("Email text")
    Set Ash = ActiveSheet

    'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count) ' this is the range it puts on the email, dont alter A but you can amend H
    FieldNum = 1    'Filter column =field name is where to get the email address from eg 1 column A 2 column B
                    'B because the filter range start in column A


    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:="", Unique:=True


    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
    

    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount

            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, _
                                   Criteria1:=Cws.Cells(Rnum, 1).Value
        
              
              
            'If the unique value is a mail addres create a mail
            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                        Range("G1").Value = WorksheetFunction.Max(Range("E2:E34"))
                    On Error GoTo 0
                End With

you would need to add

Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer

 

[Oximoxi]

I don't want to change my code in general. Here is what I've got:

Sub CDO_Mail()
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "mail adress"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp"

        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
        .Update
    End With

    strbody = ""


     With iMsg
        Set .Configuration = iConf
        .To = "mail adress"
        .CC = ""
        .BCC = ""
        .From = """Kontrola"" <ep.kontrola@elakov.cz>"
        .Subject = "Headline.:" & Application.WorksheetFunction.Max(Columns("A"))
        .TextBody = strbody
        .Send
    End With
    
    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
End Sub</ep.kontrola@elakov.cz>

I would like to find a way to insert last row into the "strbody". Just like in subject, where the macro automaticly inserts max value in column A.

 

[Oximoxi]

Any ideas guys? I would really appreciate any kind of help with this, I'm stuck.

 

[Oximoxi]

I assume you have to determine the area and then somehow insert it into the body. One way to determine the wanted cells would be (in my case): cells in columns A-N on the row, where the value in column A is highest. But I don't know how to correctly create this condition.

 

[daverunt]

I think you need to find the last row after it has been added and find the last column and concatenate the data in the row before assigning to the strBody variable.

Sub GetLastRow()

Dim strBody As String

Set Rng = Worksheets("Sheet1").UsedRange   ' or whatever the range is

LastRow = Rng.Rows.Count
FirstCol = 1                        'A is assumed
LastCol = Rng.Columns.Count


For c = FirstCol To LastCol
For Each cell In Cells(LastRow, c)
strTable = strTable & "  " & cell.Value
Next
Next

strBody = strTable




End Sub

 

[Oximoxi]

Hi daverunt,

first of all, thank you very much for your help. I appreciate it! I tried to fit the code you provided in to mine, but the email body is still empty. :/ I'm sure I forgot something important, but don't know what it is. :D

Sub CDO_Mail()
    Dim iMsg As Object
    Dim iConf As Object
    Dim strBody As String
    Dim Flds As Variant

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "email adress"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp"

        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
        .Update
    End With
    

Set Rng = Worksheets("06.18").UsedRange   'or whatever the range is

LastRow = Rng.Rows.Count
FirstCol = 1                        'A is assumed
LastCol = Rng.Columns.Count


For c = FirstCol To LastCol
For Each cell In Cells(LastRow, c)
strTable = strTable & "  " & cell.Value
Next
Next

strBody = strTable


     With iMsg
        Set .Configuration = iConf
        .To = "email adress"
        .CC = ""
        .BCC = ""
        .From = """sender"" <ep.kontrola@elakov.cz>"
        .Subject = "Subject" & Application.WorksheetFunction.Max(Columns("A"))
        .TextBody = strBody
        .Send
    End With
    
    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
End Sub</ep.kontrola@elakov.cz>

 

[daverunt]

Hi,

It could be because the sheet is not the active sheet when the mail is created?

For c = FirstCol To LastCol
For Each cell In Worksheets("06.18").Cells(LastRow, c) <---- change this line to specify the worksheet here.
strTable = strTable & "  " & cell.Value

You can also step through the code in the VB Editor using the F8 key.
As each line of code is passed you can hover over the variables in previous lines to see what is assigned to them.
It may give you a pointer at what/where it is going wrong.