Populate Body Text in Email with Cell Values

timmehtimtims

New Member
Joined
Jun 10, 2019
Messages
5
Hi all,

I've done reading around but could not work out how to do this sadly.


I want tocreate a button which generates an email. The body text needs to be populatedby the cell data.

I have gone forthis code initially:

HTML:
Private SubCommandButton1_Click()
'Updated byExtendoffice 2017/9/14
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    On Error Resume Next
    Set xOutApp =CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Body content" &vbNewLine & vbNewLine & _
              "This is line 1" &vbNewLine & _
              "This is line 2"
                  On Error Resume Next
    With xOutMail
        .To = "my@email.com"
        .CC = ""
        .BCC = ""
        .Subject = "Sling Order"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

But haverecently found this code which looks more comprehensive and fool proof for theother people who will use the form:

https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
HTML:
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm'Don't forget to copy the function RangetoHTML in the module.'Working in Excel 2000-2016
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want    'Set rng = Sheets("YourSheet").Range("D4:D12").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

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

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

    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        .Send   'or use .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006' Working in Office 2000-2016    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
However, I am way out of my comfort zone and would love someone to explain where and how I add the individual cell values to appear in the body text.

Also, how do Iensure that range changes depending on which row the button is on, rather thanbeing specific to a certain pre-defined cell value. There will be a button onevery row and it will need to parse the data of D, E and F of that row.
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Also, how do Iensure that range changes depending on which row the button is on, rather thanbeing specific to a certain pre-defined cell value. There will be a button onevery row and it will need to parse the data of D, E and F of that row.


Try this.
If the button is a shape then with this instruction we can know the row.
If you have another button, tell me the type of button.
And if you somehow know which row you are in.


Code:
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm'Don't forget to copy the function RangetoHTML in the module.'Working in Excel 2000-2016
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    
    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    
[COLOR=#ff0000]    Dim f As Variant[/COLOR]
[COLOR=#ff0000]    f = sh.Shapes(Application.Caller).TopLeftCell.Row[/COLOR]
[COLOR=#ff0000]    Set rng = Range("D" & f & ":F" & f)[/COLOR]
    
    
    'You can also use a fixed range if you want    'Set rng = Sheets("YourSheet").Range("D4:D12").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


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


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


    On Error Resume Next
    With OutMail
        .To = "my@email.com"
        .CC = ""
        .BCC = ""
        .Subject = "Sling Order"
        .HTMLBody = RangetoHTML(rng)
        .Send   'or use .Display
    End With
    On Error GoTo 0


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


    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 
Upvote 0
Hi Dante,

Thanks so much for getting back to me - I am not in the office today but will try this tomorrow and get back to you about the type of button that I used.

Best,
Timmeh.


Try this.
If the button is a shape then with this instruction we can know the row.
If you have another button, tell me the type of button.
And if you somehow know which row you are in.


Code:
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm'Don't forget to copy the function RangetoHTML in the module.'Working in Excel 2000-2016
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    
    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    
[COLOR=#ff0000]    Dim f As Variant[/COLOR]
[COLOR=#ff0000]    f = sh.Shapes(Application.Caller).TopLeftCell.Row[/COLOR]
[COLOR=#ff0000]    Set rng = Range("D" & f & ":F" & f)[/COLOR]
    
    
    'You can also use a fixed range if you want    'Set rng = Sheets("YourSheet").Range("D4:D12").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


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


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


    On Error Resume Next
    With OutMail
        .To = "my@email.com"
        .CC = ""
        .BCC = ""
        .Subject = "Sling Order"
        .HTMLBody = RangetoHTML(rng)
        .Send   'or use .Display
    End With
    On Error GoTo 0


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


    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 
Upvote 0
Hi Dante,

Thanks so much for getting back to me - I am not in the office today but will try this tomorrow and get back to you about the type of button that I used.

Best,
Timmeh.

All right, I'll wait for news from you.
 
Upvote 0
Hi Dante,

The Button that I have used is a form control button.

I have tried that code by inserting a shape, however I have had no luck getting it to run the Macro - comes up with the error "Macro may not be available in this workbook or all macros may be disabled", which seems quite generic - I've set this up on a Macros enabled workbook and have Macros and Active X on.

I initially tried using a form control button, however cannot get this code to work with that either.

As an aside - I have 3 sheets on this workbook and each sheet will have approximately 40 individual buttons on each sheet, with a button on each line.

Any more help would be brilliant!

Cheers,
Timmeh.
 
Upvote 0
Hi Dante,

I have decided to use a more simple code which I have a chance of understanding. The other was too complicated for me to edit and get my head around.

I have updated my code which runs when a form control button is pressed:

Code:
Sub Button23_Click()
'Updated byExtendoffice 2017/9/14
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    On Error Resume Next
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "[COLOR=#ff0000]C[/COLOR]" & vbNewLine & vbNewLine & _
              [LEFT][COLOR=#222222][FONT=Verdana]"[/FONT][/COLOR][/LEFT][COLOR=#ff0000][LEFT]D[/LEFT][/COLOR][LEFT][COLOR=#222222][FONT=Verdana]" & vbNewLine & _[/FONT][/COLOR][/LEFT]
              "[COLOR=#ff0000]E[/COLOR]" & vbNewLine & _
              "[COLOR=#ff0000]F[/COLOR]"
                  On Error Resume Next
    With xOutMail
        .To = "my@email.com"
        .CC = ""
        .BCC = ""
        .Subject = "Sling Order - [COLOR=#ff0000]SHEET NAME[/COLOR]"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

There are 3 sheets and there are approximately 40 buttons on each sheet.

Each button triggers an email to be sent, parsing 4 cell values to the email body text. Each cell value range=(C-F) is equal to the row that the button is on. I have tried and tried by simply adding this range, or just the basic cell value into the body text function xMailBody, but just cannot get it to work. :(

Also, as an added bonus, I'd really like the sheet name to be populated into the email subject. Not essential but would be great if it was an easy fix.

Any help would be massively appreciated.

Many thanks,
Timmeh.
 
Upvote 0
Hi Dante,

I have decided to use a more simple code which I have a chance of understanding. The other was too complicated for me to edit and get my head around.

I have updated my code which runs when a form control button is pressed:

There are 3 sheets and there are approximately 40 buttons on each sheet.

Each button triggers an email to be sent, parsing 4 cell values to the email body text. Each cell value range=(C-F) is equal to the row that the button is on. I have tried and tried by simply adding this range, or just the basic cell value into the body text function xMailBody, but just cannot get it to work. :(

Also, as an added bonus, I'd really like the sheet name to be populated into the email subject. Not essential but would be great if it was an easy fix.

Any help would be massively appreciated.

Many thanks,
Timmeh.

Try the following.
All form buttons must be assigned to the Button_Click macro.


The following code will take the row of the format button and will display a message with the data of the row.
After these tests you can remove the msgbox and add the rows for the mail.

Code:
Sub [B]Button_Click[/B]()
    Dim f As Variant
    f = ActiveSheet.DrawingObjects(Application.Caller).TopLeftCell.Row
    xMailBody = Range("C" & f) & vbNewLine & vbNewLine & _
                Range("D" & f) & vbNewLine & _
                Range("E" & f) & vbNewLine & _
                Range("F" & f)
    
    MsgBox xMailBody
End Sub
 
Upvote 0
That's brilliant. I will test it out tomorrow; I only have a Mac at home so can't test it this evening, however the pop up message worked so I'm sure it will be all good.

Code:
Sub Button23_Click()
Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    On Error Resume Next
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    Dim f As Variant
    f = ActiveSheet.DrawingObjects(Application.Caller).TopLeftCell.Row
    xMailBody = Range("C" & f) & vbNewLine & vbNewLine & _
                Range("D" & f) & vbNewLine & _
                Range("E" & f) & vbNewLine & _
                Range("F" & f)
    
                  On Error Resume Next
    With xOutMail
        .To = "my@email.com"
        .CC = ""
        .BCC = ""
        .Subject = "Sling Order - SHEET NAME"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

Try the following.
All form buttons must be assigned to the Button_Click macro.


The following code will take the row of the format button and will display a message with the data of the row.
After these tests you can remove the msgbox and add the rows for the mail.

Code:
Sub [B]Button_Click[/B]()
    Dim f As Variant
    f = ActiveSheet.DrawingObjects(Application.Caller).TopLeftCell.Row
    xMailBody = Range("C" & f) & vbNewLine & vbNewLine & _
                Range("D" & f) & vbNewLine & _
                Range("E" & f) & vbNewLine & _
                Range("F" & f)
    
    MsgBox xMailBody
End Sub
 
Upvote 0
That's brilliant. I will test it out tomorrow; I only have a Mac at home so can't test it this evening, however the pop up message worked so I'm sure it will be all good.

Okay, let me know any doubt.
 
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,048
Members
448,543
Latest member
MartinLarkin

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