Outlook Mail Automation Modification

Hi All,

I have modified a VBA code from Ron de Bruin Excel Automation.

Its working fine but I want to add something more in this. Please help me to add below steps.

".to" is taking value from column B of excel Sheet 1.
1) So I want ".cc" should take value from column D,
2) ".bcc" should take value from column E and ".
3) ".Subject" should take value from column F.

Below is modified code from http://www.rondebruin.nl/win/s1/outlook/amail6.htm

Sub Mail_Outlook_With_Signature_Html()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set sh = Sheets("Sheet1")
    
    Set OutApp = CreateObject("Outlook.Application")
        
    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
    
    strbody = "<br>Hello,</br>" & _
              "<p>My name is Liz.<br></p>" & _
              "<p></p>"

    On Error Resume Next

    With OutMail
        .Display
        .to = cell.Value
        .CC = ""
        .BCC = ""
        .Subject = ""
        .HTMLBody = strbody & "<br>" & .HTMLBody
    
    For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With
            
            On Error GoTo 0
            Set OutMail = Nothing
            Set OutApp = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub

Thanks,
Liz.

Hi there, how to answer your question depends on whether or not there are equal numbers of entries in columns B,D,E? It will also depend on whether these are the only entries on that worksheet and that you want to send the same e-mail to all recipients.

If so, then I would use:

Dim Tomail,CCmail,BCCmail,Subjectmail as String
Worksheets("YOURWORKSHEETNAME").Activate

lastrow = Activesheet.UsedRange.Rows.Count

For i = 2 to lastrow 'Assume you have headers in row 1
Tomail = Tomail & Cells(i,2).Value & ";"
CCmail = CCmail  & Cells(i,4).Value & ";"
BCCmail = BCCMaill & Cells(i,5).Value & ";"
Next i

Subjectmail = Cells(2,6).Value 'Assuming only one subject

' . . . . . Skip to e-mail section . . .
     .To = Tomail
     .CC = CCmail
     .BCC = BCCMail
     .Subject = Subjectmail

Hope this helps.

Liz,

I'm not 100% sure what you want the code to do, some of it appears to be redundant (line 21 for instance, what is it meant to be doing for each cell in column B?).

You are setting the range of the filepath range to encompass all columns between C and Z, which will catch not only file paths but also CCs,BCCs and Subjects. This should be .Range(Cells(2,3),Cells(lastrow,3)).

Declare lastrow as soon as you open the sheet, this means you can use it immediately.

You've changed my suggested code about the '.to' section of the with Outmail section, this won't work as it is only pointing to one cell (as opposed to my method which concatenates all relevant cells in column B.

I'd recommend going over Ron de Bruin's webpage again, step by step, as it is much better than I in explaining e-mail automation. Fundamentally, it boils down to this:

For all parts of the e-mail that have more than one component, saving attachments, (i.e. to,CC, BCC) you can concatenate these into a string, delimited by a semi-colon, then just use that string as the value within the 'With Outmail' section.

As I've answered your initial question, I'd be grateful if you could mark the question as 'solved' and add reputation if any of my advice has helped.

Best,

TKCZBW