Send email with bold font using VBA

VbaHell

Well-known Member
Joined
Jan 30, 2011
Messages
1,220
Hello all

I hope you can help on this please

This code sends out emails from the contact list which works fine and takes the body of the email content from range G1:G53. What I am trying to do is change the font to Bold from Range G14:G23.

Any ideas please

[Sub Test1()

Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strbody As String Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

For Each cell In Range("G1:G53")
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, "C").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Testing"
.Body = "Attention " & Cells(cell.Row, "A").Value & vbNewLine & vbNewLine & strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True

End Sub]
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
You'll need to use the HTMLBody property, along with HTML formatting tags. Note that I've commented out "On Error Resume Next" and "On Error GoTo 0" since you already have "On Error GoTo cleanup" to handle errors. Also, note that a space has been added after each occurrence of < to prevent this Board from interpreted it as HTML code. Therefore, remove those spaces from the code.

Code:
[COLOR=darkblue]Sub[/COLOR] Test1()

    [COLOR=darkblue]Dim[/COLOR] OutApp [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] OutMail [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] cell [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] strHTMLBody [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    
    [COLOR=darkblue]Set[/COLOR] OutApp = CreateObject("Outlook.Application")
    
    strHTMLBody = ""
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] Range("G1:G53")
        [COLOR=darkblue]If[/COLOR] Intersect(cell, Range("G14:G23")) [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
            strHTMLBody = strHTMLBody & cell.Value & "< br>"
        [COLOR=darkblue]Else[/COLOR]
            strHTMLBody = strHTMLBody & "< b>" & cell.Value & "< /b>< br>"
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]Next[/COLOR]
    
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] cleanup
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        [COLOR=darkblue]If[/COLOR] cell.Value [COLOR=darkblue]Like[/COLOR] "?*@?*.?*" And _
            LCase(Cells(cell.Row, "C").Value) = "yes" [COLOR=darkblue]Then[/COLOR]
                [COLOR=darkblue]Set[/COLOR] OutMail = OutApp.CreateItem(0)
                [COLOR=green]'On Error Resume Next[/COLOR]
                [COLOR=darkblue]With[/COLOR] OutMail
                    .To = cell.Value
                    .Subject = "Testing"
                    .HTMLBody = "Attention " & Cells(cell.Row, "A").Value & "< br>< br>" & strHTMLBody
                    .Send
                [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
                [COLOR=green]'On Error GoTo 0[/COLOR]
                [COLOR=darkblue]Set[/COLOR] OutMail = [COLOR=darkblue]Nothing[/COLOR]
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]Next[/COLOR] cell
    
cleanup:
    [COLOR=darkblue]Set[/COLOR] OutApp = [COLOR=darkblue]Nothing[/COLOR]
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]


[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

Hope this helps!
 
Last edited:
Upvote 0
Hi Domenic

thanks very much for your reply, i used your concept but coded the < br> in the spreadsheet so I could format each line spacing as I wanted, now works great thanks to you

on another area is it possible to add a jpeg after the signature please
 
Upvote 0
You're very welcome, glad I could help!

To add an image to an email, first the jpg is attached to the email, and then HTML code is used to insert the image within the body of the email...

Code:
Sub Test1()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim strHTMLBody As String
    
    Application.ScreenUpdating = False
    
    Set OutApp = CreateObject("Outlook.Application")
    
    strHTMLBody = ""
    For Each cell In Range("G1:G53")
        If Intersect(cell, Range("G14:G23")) Is Nothing Then
            strHTMLBody = strHTMLBody & cell.Value & "< br>"
        Else
            strHTMLBody = strHTMLBody & "< b>" & cell.Value & "< /b>< br>"
        End If
    Next
    
    On Error GoTo cleanup
    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
            LCase(Cells(cell.Row, "C").Value) = "yes" Then
                Set OutMail = OutApp.CreateItem(0)
                'On Error Resume Next
                With OutMail
                    .To = cell.Value
                    .Subject = "Testing"
[COLOR=#ff0000]                    .Attachments.Add "c:\users\domenic\pictures\sample.jpg"[/COLOR]
                    .HTMLBody = "Attention " & Cells(cell.Row, "A").Value & "< br>< br>" & strHTMLBody[COLOR=#ff0000] & "< br>< br>< img src=""cid:sample.jpg"">"[/COLOR]
                    .Send
                End With
                'On Error GoTo 0
                Set OutMail = Nothing
        End If
    Next cell
    
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True


End Sub

Change the path and filename of the image, accordingly. Also, don't forget to remove the spaces after each "<".

Hope this helps!
 
Upvote 0

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top