Copy formatted cell content to email body

[Alsiro]

Hello!

I'm currently building a macro that is supposed to copy a formatted cell content (I.E.: a cell with bold, italic and some coloured text like below)

The problem is, I'm not managing to copy the cell content with the formatted text. It only goes as plain text.

Does someone knows how to do it?

I already tried by doing HTMLBody but it's not the result I want it.


Thanks!

 

[shadow12345]

have you tried this one?

Sub CreateMail()

    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngTo As Range
    Dim rngCc As Range
    Dim rngSubject As Range
    Dim rngBody As Range

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    With ActiveSheet
        Set rngTo = .Range("B1")  ' you can add a direct email instead of adding it from the sheet
        Set rngCc = .Range("B2") '  ' you can add a direct email instead of adding it from the sheet
        Set rngSubject = .Range("a2")
        Set rngBody = .Range(.Range("B2"), .Range("B2        ").End(xlDown))
    End With
    rngBody.Copy

    With objMail
        .To = rngTo.Value
        .Cc = rngCc.Value
        .Subject = rngSubject.Value
        .Display
    End With
    SendKeys "^({v})", True

    Set objOutlook = Nothing
    Set objMail = Nothing
    Set rngTo = Nothing
    Set rngCc = Nothing
    Set rngSubject = Nothing
    Set rngBody = Nothing

End Sub

 

[Alsiro]

Wow, thank you so much for your reply! It's working now

I've spent days looking for that solution.

Really thanks!

 

[shadow12345]

You're most welcome.

 

[Alsiro]

I have one more doubt, is it possible to add some content before the text?

Something like:

Sub Mail_Outlook()


    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngSubject As range
    Dim rngBody As range

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    With ActiveSheet
        Set rngSubject = .range("A2")
        Set rngBody = .range(.range("B2"), .range("B2        "))
    End With
    rngBody.Copy
    
    With objMail
        .To = "thatsmy@email.com"
        .subject = rngSubject.Value
        .Body = "Hello!!"
        .Display
    End With
   SendKeys "^({v})", True


    Set objOutlook = Nothing
    Set objMail = Nothing
    Set rngTo = Nothing
    Set rngSubject = Nothing
    Set rngBody = Nothing
     

End Sub

The problem is that the pasted text goes before the Body message 'Hello!!'

Edit: What I would like to do is to create some fixed message with some content copied from excel like:

"Hello! (this text never change)

I want this text .... (this text I would change when interest me, since it comes from a cell)
"

 

[Alsiro]

*bump*

 

[shadow12345]

Hi Alsiro,

Sorry I was afk. Try this one.

Sub Marine()

    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngTo As Range
    Dim rngCc As Range
    Dim rngSubject As Range
    Dim rngBody As Range

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    With ActiveSheet
        Set rngTo = .Range("B1")  ' you can add a direct email instead of adding it from the sheet
        Set rngCc = .Range("B2") '  ' you can add a direct email instead of adding it from the sheet
        Set rngSubject = .Range("a2")
        Set rngBody = .Range(.Range("B3"), .Range("B3        ").End(xlDown))
    End With
    rngBody.Copy

    With objMail
        .To = rngTo.Value
        .Cc = rngCc.Value
        .Subject = rngSubject.Value
        .Display
    End With
    SendKeys ("Hello Here Is Some Other Body Text ")
    SendKeys "^({v})", True

    Set objOutlook = Nothing
    Set objMail = Nothing
    Set rngTo = Nothing
    Set rngCc = Nothing
    Set rngSubject = Nothing
    Set rngBody = Nothing

End Sub

 

[Alsiro]

Hello shadow, no problem at all.

It's working but it's not 100% what I would like to see.

It would be better if I manage to mix the SendKeys with HTMLBody in the same email body, because I must write in bold a message like:

"Dear Mr. X, good (morning, evening or afternoon depending on time. I already did a function for this)"

Like:

Sub Marine()

    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngTo As Range
    Dim rngCc As Range
    Dim rngSubject As Range
    Dim rngBody As Range

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    With ActiveSheet
        Set rngTo = .Range("B1")  ' you can add a direct email instead of adding it from the sheet
        Set rngCc = .Range("B2") '  ' you can add a direct email instead of adding it from the sheet
        Set rngSubject = .Range("a2")
        Set rngBody = .Range(.Range("B3"), .Range("B3        ").End(xlDown))
    End With
    rngBody.Copy

    With objMail
        .To = rngTo.Value
        .Cc = rngCc.Value
        .Subject = rngSubject.Value
        .HTMLBody = "[B]Hello, here is some[/B] other body text"
        .Display
    End With

    SendKeys "^({v})", True

    Set objOutlook = Nothing
    Set objMail = Nothing
    Set rngTo = Nothing
    Set rngCc = Nothing
    Set rngSubject = Nothing
    Set rngBody = Nothing

End Sub

I don't know if I'm beign clear, but it's really important to have that mix, since I am using some other functions.

I could poist my entire code if you prefer.

Regards in advance.


edit.: This is my full code

Sub Mail_Outlook()

Dim OutApp As Object
Dim OutMail As Object
Dim subject As Object
Dim cellRange As range
Dim sh As Worksheet
Dim cell As range
Dim FileCell As range

Dim rngBody As range
Dim i As Integer

LastRow = ActiveSheet.range("A" & Rows.Count).End(xlUp).Row


 If Cells(LastRow, 1).Value <> "" Then
 
 MailTo = ActiveWorkbook.Worksheets("Contatos").Cells(LastRow, 1).Offset(0, 1).Value

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Contatos")

    Set OutApp = CreateObject("Outlook.Application")

    i = 0
    ' loop para criar emails separados
    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set cellRange = sh.Cells(cell.Row, 1).range("C1:Z1")
        MailSubject = ActiveWorkbook.Worksheets("Email").Cells(2, 1)

        Dim tmp As String
        
        tmp = "Prezado(a) " & ActiveWorkbook.Worksheets("Contatos").Cells(cell.Row, 1).Offset(0, 0).Value & ", " & getPeriodo & "." & vbNewLine
        SendKeys (tmp)
        
        
        ' Copy Cell content
        With ActiveWorkbook.Worksheets("Email")
            Set rngBody = .range(.range("B2"), .range("B2"))
        End With
        rngBody.Copy
        
        

        ' generate email body
        MailBody = "[B]Prezado(a) " & ActiveWorkbook.Worksheets("Contatos").Cells(cell.Row, 1).Offset(0, 0).Value & ", " & getPeriodo & ".[/B]


" & vbNewLine & _
                    "" & vbTab & vbNewLine & "
"


        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(cellRange) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .To = cell.Value
                .subject = MailSubject
                .HTMLBody = MailBody
                'ou .Body ou .BodyPasteSpecial
                
                ' attach pdf dile on cell C2 and so on
                .Attachments.Add "C:\Users\sixel\Desktop\DNV\Certificados\" & i & "_" & ActiveWorkbook.Worksheets("Contatos").Cells(2, 3).Value & ".pdf"

        End If
                'Next FileCell
                
                .Display  'Or use .Send
            End With

            Set OutMail = Nothing
        End If
        i = i + 1

    ' ctl+v to outlook
        SendKeys "^({v})", True
        
        Next cell

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

Set rngBody = Nothing

End Sub

Private Sub Wait(ByVal nSec As Long)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

Function getPeriodo() As String
    If Now - Date < 0.5 Then
        getPeriodo = "bom dia"
    ElseIf Now - Date < 0.75 Then
        getPeriodo = "boa tarde"
    Else
        getPeriodo = "boa noite "
    End If
End Function

Function RangetoHTML(rng As range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[shadow12345]

Hi,

Im not sure how to mix HTML body with this type of code.... but what you could do, is add the other functions to the data in the excel sheet you are copying.

By that I mean, if we are taking range b1 to b3 for example, you could insert a row and add the "Dear Mr. X, good (morning, evening or afternoon depending on time. I already did a function for this)" into that cell... so it all gets copied over by the send key

 

[Alsiro]

It was exactly what I did
Cheers