Extract Data to Email Body (from a VBA newbie)

-emma-

Board Regular
Joined
Jul 14, 2006
Messages
184
Office Version
  1. 365
Platform
  1. Windows
Hi all,

I have a form that staff complete.

Cells A1:B6 contains information.

I need VBA writing to complete the following:

Send to designated email address
Subject line to be B1 and B2 (example "Mr Smith 12 May 2019")
Copy information from A1:B6 into the body of the email

The user should complete the relevant boxes and hit the "Send Email" button and be presented with a pre populated email where they are just required to press Send.

Any help would be greatly appreciated on this please.

Thanks

Emma
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
.
Your UserForm should enter the appropriate information into Sheet1. Then call the macro listed below :


Code:
Option Explicit


Sub Mail_Selection_Range_Outlook_Body()
' You need to use this module with the RangetoHTML subroutine.
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
' Thanks to Ron DeBruin and Microsoft for their examples  https://www.rondebruin.nl/
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail
    Dim subLine As String
    'Dim RangetoHTML
    Set rng = Nothing
    
    'On Error Resume Next
    
    ' Only send the visible cells in the selection.
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    ' You can also use a range with the following statement.
    Set rng = Sheets("Sheet1").Range("A1:B6").SpecialCells(xlCellTypeVisible)
    subLine = Sheets("Sheet1").Range("B1").Value & " " & Sheets("Sheet1").Range("B2").Value


    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 = "To Email Here"
        .CC = ""        '<-- CC Email here
        .BCC = ""       '<-- BCC Email here
        .Subject = subLine
        .HTMLBody = "Dear :  " & "<br><br><br>" & _
                    "Please review this latest data : " & "<br><br>" & _
                    "" & RangetoHTML(rng) & "<br><br><br>" & _
                    "Let us know if we can provide any additional information or assistance." & "<br><br>" & _
                    "Sincerely, " & "<br><br>" & _
                    "John Doe"
            ' In place of the following statement, you can use ".Display" to
            .Display
            '.Send
    End With
    On Error GoTo 0


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Sheets("Sheet1").Range("AA1:AP63").Clear
    Sheets("Sheet1").Range("A1").Select
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub




Function RangetoHTML(rng As Range)
    
    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 workbook to receive the data.
    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 an .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 the RangetoHTML subroutine.
    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.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Upvote 0
I know how to set up the button and apply the macro, but above that, I'm pretty useless with everything else.

When I run this, I get "Compile error: Expected End Function" and the debug takes me to "Function RangetoHTML(rng As Range)"

Am I doing it wrong? Have I missed something out?

Sorry for my neediness...I did say I was a newbie ;)
 
Upvote 0
All of the code needs to be pasted into a regular module.

Presently, as the code is written, you would 'hard code' the TO email address into the macro.

The error you are receiving sounds like it is missing END FUNCTION at the very bottom of the macro code.
 
Last edited:
Upvote 0
This is now working perfectly. Thank you so much!
 
Upvote 0

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

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