# Formatting the body of an Outlook email?



## jmpatrick (Nov 22, 2021)

Good morning.  I have this code that creates an Outlook email message based on data from my Sheet and sends to the person I select.  Now I'm wondering if it's possible to format the body of the message...


```
Sub SendPlanRequestUpdateEmail()

    Call FloorPlanRequests
    
    Dim Ans As VbMsgBoxResult
    Ans = MsgBox("Are you sure you want to Send a Floor Plan Request Update?", vbYesNo + vbQuestion)
    If Ans = vbNo Then Exit Sub
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Sheets("FloorPlanRequests").Visible = True
    Sheets("FloorPlanRequests").Select
    ActiveSheet.Unprotect

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    Set rng = Sheets("FloorPlanRequests").Range("FloorPlanRequests").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Settings.DesignerEmailReturn.Value
        .CC = Settings.CCNames.Value
        .Subject = "Floor Plan Request Update for " & Format(Now, "m/dd/yy")
        .HTMLBody = "In order of priority:" & "<br>" & RangetoHTML(rng) & "<br>" & "Thanks!"
        .Send
    End With
    On Error GoTo 0
    
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("FloorPlanRequests").Visible = False
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Sheets("Calendar").Select
   
End Sub
```


----------



## lrobbo314 (Nov 22, 2021)

Not sure what you mean exactly by formatting, but here is an example where the body of the email is being made to be a certain font, red color, 20pt font size, and made bold.


```
Sub OLF()
Dim oApp As Object:     Set oApp = CreateObject("Outlook.Application")
Dim oM As Object:       Set oM = oApp.createitem(0)

With oM
    .to = "You"
    .Subject = "Test"
    .htmlbody = "<b><p style=""font-family:courier;color:red;font-size:20pt;"">This is a paragraph.</p></b>"
    .display
End With

Set oM = Nothing
Set oApp = Nothing
End Sub
```


----------



## jmpatrick (Nov 22, 2021)

lrobbo314 said:


> Not sure what you mean exactly by formatting, but here is an example where the body of the email is being made to be a certain font, red color, 20pt font size, and made bold.
> 
> 
> ```
> ...



That works fine but I can't figure out how to apply the formatting to the data that comes over from *RangetoHTML(rng)*.


----------



## jmpatrick (Nov 22, 2021)

lrobbo314 said:


> Not sure what you mean exactly by formatting, but here is an example where the body of the email is being made to be a certain font, red color, 20pt font size, and made bold.
> 
> 
> ```
> ...



Using your suggestion I was able to include the data I needed:


```
.htmlbody = "<b><p style=""font-family:courier;color:red;font-size:20pt;"">In order of priority:</p></b>" & "<br>" & RangetoHTML(rng) & "<br>" & "<b><p style=""font-family:courier;color:red;font-size:20pt;"">Thanks!</p></b>"
```

Thanks!


----------



## jmpatrick (Dec 6, 2021)

Looping back to this (and answering my own original question in case someone else is trying to format the body of their vba-generated email messages).  This is what finally worked for me:


```
Sub SendPlanRequestUpdateEmail()
    
    Dim Ans As VbMsgBoxResult
    Ans = MsgBox("Are you sure you want to Send a Floor Plan Request Update?", vbYesNo + vbQuestion)
    If Ans = vbNo Then Exit Sub
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Sheets("FloorPlanRequests").Visible = True
    Sheets("FloorPlanRequests").Select
    ActiveSheet.Unprotect

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    Set rng = Sheets("FloorPlanRequests").Range("FloorPlanRequests").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Settings.DesignerEmailReturn.Value
        .CC = Settings.CCEmailReturn.Value
        .BCC = Settings.BCCEmailReturn.Value
        .Subject = "Floor Plan Request Update for " & Format(Now, "m/dd/yy")
        .htmlbody = "<spanfont-size:14pt;"">In order of priority:" & RangetoHTML(rng) & "<br>" & Settings.FloorPlanRequestMessage.Value
        .Send
    End With
    On Error GoTo 0
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
      
End Sub
```

*RangetoHTML(rng) *is a nice piece of code sourced from Ron de Bruin's excellent Excel Automation website.  The code allows you to use a range to form the body of an email message.



			Mail Range/Selection in the body of the mail


----------



## jmpatrick (Dec 21, 2022)

Good morning, Mr. Excel-lovers!

I need to revisit this one.  I'm having three issues as shown in the screen shot below.

- I need to get rid of the blank line that shows up above the *RangetoHTML(Rng)* text.
- I need a blank line/carriage return between *Flex 2 Room* and *This home is the model*.  You'll see *& vbCrLf* in my code below.  Doesn't work.
- The text that comes from the *Settings.FloorPlanRequestMessageRequest.Value* should be 14pt. like the rest of the message body.








```
Sub SendPlanRequestEmail()

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Sheets("Calendar").Select
    
    Call RememberWindowPosition
    
    Range("P" & (ActiveCell.Row)).Select
    Range(ActiveCell.Address).Name = "StartCell"
    
    Call FloorRequest
    Call SendFloorRequestRange
    
    Dim r As Range, x, c, d, Y, a
    x = Settings.DesignerNamesRequest.Value
    c = Settings.CCNamesRequest.Value
    d = Settings.BCCNamesRequest.Value
    Y = Worksheets("SendFloorRequest").Range("L1").Value
    
    'Dim Ans As VbMsgBoxResult
    
    'Ans = MsgBox("Are you sure you want to send a Floor Plan Request for " & Y & " to the following? " & vbCrLf & _
    'vbCrLf & _
    'x & vbCrLf & _
    'c & vbCrLf & _
    'd, vbYesNo + vbQuestion)
    
    'If Ans = vbNo Then Exit Sub
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Dim Rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set Rng = Nothing
    On Error Resume Next
    Set Rng = Selection.SpecialCells(xlCellTypeVisible)
    Set Rng = Sheets("SendFloorRequest").Range("FloorPlanRequestRange").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Settings.DesignerEmailReturnRequest.Value
        .CC = Settings.CCEmailReturnRequest.Value
        .BCC = Settings.BCCEmailReturnRequest.Value
        .Subject = Worksheets("SendFloorRequest").Range("K1").Value
        .htmlbody = RangetoHTML(Rng) & vbCrLf & Settings.FloorPlanRequestMessageRequest.Value
        .Attachments.Add Worksheets("SendFloorRequest").Range("I1").Value
        .Attachments.Add Worksheets("SendFloorRequest").Range("I2").Value
        .display
        '.Send
    End With
    On Error GoTo 0
    
    'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("FloorPlanRequests").Visible = False

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Sheets("Calendar").Select
    
    Application.GoTo "StartCell"
    
    ActiveCell.FormulaR1C1 = "'" & Format(Now, "m/d")
    
    Range("P" & (ActiveCell.Row)).Select
    Range(ActiveCell.Address).Name = "StartCell"
  
    Dim vCellValue As Variant
    Dim sText As String
  
    vCellValue = ActiveCell.Value
    If IsNumeric(vCellValue) Then
        vCellValue = CDbl(vCellValue)
    End If
    
    x = Settings.DesignerNamesRequest.Value
      
    sText = Application.UserName & ":" & vbCrLf
    sText = sText & "Sent to " & x & vbCrLf
    sText = sText & Format(Now, "M/DD/YY H:MM AM/PM")
  
    With ActiveCell
        .ClearComments
        With .AddComment
            .Text sText
            With .Shape
                .TextFrame.Characters(1, InStr(sText, ":")).Font.Bold = True
                .Width = 180
                .Height = 60
                With .TextFrame.Characters.Font
                   .Name = "Tahoma"
                   .Size = 12
                End With
                With .TextFrame
                   .AutoSize = True
                End With
            End With
        End With
    End With
    
    Range("DA" & (ActiveCell.Row)).Value = Settings.DesignerNamesRequest.Value
    Range("DB" & (ActiveCell.Row)).Value = [Text(Now(), "MM/DD/YYYY HH:MM:SS AM/PM")]
    Range("DD" & (ActiveCell.Row)).Value = [Text(Now(), "M/D")]

    
    Call RestoreWindowPosition
    
    Call FloorPlanRequestsClear
    Call RunPlanRequests
    Call FloorPlanRequestsFormulasRange
    Call FloorPlanRequestsFormulasPaste
    Call FloorPlanRequestsRange
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   
End Sub
```


----------

