Outlook Mail Automation Modification

[Liz_Biz]

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.