VBA Code to paste multiple ranges into email and send

[Knockout1992]

Hello all,

I am trying get the following code to selecxt different ranges and send via outlook however I receive a blank email. Any support would be grateful. I think it is something wrong with the set rng1 thro' to set rng but I honestly do not know.

Sub Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim rng2 As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String



Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection

Set rng1 = Range("B1:L17")
Set rng2 = Range("B64:L74")
Set rng3 = Range("B91:L101")
Set rng = Union(rng1, rng2, rng3)

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

StrBody = "Hi<br><br>You have had a CAR raised against you for " & Range("J14") & ". Please read the information below and action the required correction WITHIN 1 HOUR. Please fill out the correction info below and reply to this mail. Thank you.<br><br>CAR Reason"



senderlookup = Sheets("Lookup_List").Range("A:B")
receiverlookup = Sheets("Lookup_List").Range("C:D")
cclookup = Sheets("Lookup_List").Range("C:E")

Sender = Application.VLookup(Sheets("CAR_Input").Range("E6"), senderlookup, 2, False)
receiver = Application.VLookup(Sheets("CAR_Input").Range("J12"), receiverlookup, 2, False)
ccd = Application.VLookup(Sheets("CAR_Input").Range("J12"), cclookup, 3, False)

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

On Error Resume Next
With OutMail
.To = receiver
.CC = Sender & "; " & ccd
.BCC = ""
.Subject = "CAR - " & Range("J14") & Range("N1") & Range("J8").Value
.HTMLBody = StrBody & RangetoHTML(rng)
.send


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)

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


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 xublishsource=", _
"align=left xublishsource=")

'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

 

[Wookiee]

I dummied up a spreadsheet to try and test this and my issue was getting the full range to paste into the email (it was only pasting the first of three sections into the email). But then I figured if you used the RangeToHTML function for each section instead of joining them using Union, and that worked. Please try this

Sub Knockout_1992()
'Code tweaked by Wookiee at MrExcel.com


'Declare Variables
Dim rng         As Range
Dim rng1        As Range
Dim rng2        As Range
Dim rng3        As Range
Dim rngCC       As Range
Dim rngReceiver As Range
Dim rngSender   As Range
Dim olApp       As Object
Dim olMsg       As Object
Dim strBody     As String
Dim strCC       As String
Dim strReceiver As String
Dim strSender   As String
Dim strSubject  As String

'Only Select Specified Cells
On Error Resume Next

Set rng1 = Range("B1:L17")
Set rng2 = Range("B64:L74")
Set rng3 = Range("B91:L101")
'Set rng = Union(rng1, rng2, rng3)

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

'Create HTML Body Text
strBody = "Hi<br><br>You have had a CAR raised against you " & _
  "for " & Range("J14") & ". Please read the information " & _
  "below and action the required correction WITHIN 1 HOUR. " & _
  "Please fill out the correction info below and reply to " & _
  "this mail. Thank you.<br><br>CAR Reason"
strBody = strBody & RangetoHTML(rng1)
strBody = strBody & RangetoHTML(rng2)
strBody = strBody & RangetoHTML(rng3)

'Extract Email Data
Set rngSender = Sheets("Lookup_List").Range("A:B")
Set rngReceiver = Sheets("Lookup_List").Range("C:D")
Set rngCC = Sheets("Lookup_List").Range("C:E")

strSender = Application.VLookup _
  (Sheets("CAR_Input").Range("E6"), rngSender, 2, 0)
strReceiver = Application.VLookup _
  (Sheets("CAR_Input").Range("J12"), rngReceiver, 2, 0)
strCC = Application.VLookup _
  (Sheets("CAR_Input").Range("E6"), rngCC, 3, 0)

strSubject = "CAR - " & Range("J14") & Range("N1") & Range("J8")


'Create Email Message
Set olApp = CreateObject("Outlook.Application")
Set olMsg = olApp.CreateItem(0)

On Error Resume Next

   Set olApp = GetObject(, "Outlook.Application")

   If olApp Is Nothing Then _
      Set olApp = CreateObject("Outlook.Application")

   Set olMsg = olApp.CreateItem(0)

   With olMsg

    .To = strReceiver
    .CC = strSender & "; " & strCC
    .Subject = strSubject
    .HTMLBody = strBody
    .Display '.Send

  End With

On Error GoTo 0

With Application

  .EnableEvents = True
  .ScreenUpdating = True

End With

'Clear Set Variables
Set olApp = Nothing
Set olMsg = Nothing

End Sub

 

[Knockout1992]

Many thanks all sorted with your changes