VBA send email with multiple cells in body

[pimco123]

Hi

Would someone be able to help with the VBA code to get VBA to send a table of data from excel using Outlook?

Eg: how do you get the below table of data (spread across 4 rows and 4 colulmns) into an Outlook email body?

Account Water Earth Fire
123 48 7 6
1234 4 65 0
12345 54 74 4


I have the below code which I use to generate emails but the body field of the email only picks up data from one column, I am trying to include the above table into the email body.

Thank you so much

Sub Email12()
EmailNo = 0
Range("B2").Select
Do Until ActiveCell.Offset(0, -1) = Range("C2").Value
ActiveCell.Offset(1, 0).Select
Loop

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ActiveCell.Offset(0, 1).Value
.CC = ActiveCell.Offset(1, 1).Value
.Subject = ActiveCell.Offset(2, 1).Value

Do Until ActiveCell.Value = "Subject:"
ActiveCell.Offset(1, 0).Select
Loop

ActiveCell.Offset(1, 0).Select

Do Until ActiveCell.Value = Range("C3")
ActiveCell.Offset(1, 0).Select
.body = .body + ActiveCell.Value + vbCrLf

Loop

.Display

End With
Range("A1").Select

End Sub

 

[Manixim]

Hi There. I know its an old thread but just have a quick question as an addition to sending email and disabling the code for x amount of time. i.e heres the problem: lets say I want to send an email if A1 >= B1 ... so it will send an email but if A1 stays more than B1 it keeps sending the emails every time the cell data changes; So My question is: Is it possible to limit lets say 1 email per X minutes; i.e send an email and disable sending email for 15 min for example.

 

[satishmundra84]

I would say more than excellent.
Truly extreme logical.

 

[SameerPatole]

I used search, and this will work perfect with my application. However, the range I need to copy has our logo in it and is NOT copying over? Is there a way to copy the range as a picture? If I copy the range manually and paste into Outlook as a picture the format is perfect.

Thank you,
Dan

I want to be able to send cells from an excel workSHEET which contains table, images and text in HTML format via Outlook.
can we do this. I am currently using below code which lacks capability to include image.

========================================
Sub NotificationMail()




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


Set rng = Nothing
On Error Resume Next


Set rng = ActiveCell.SpecialCells(xlCellTypeVisible)


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
Set .SendUsingAccount = OutApp.Session.Accounts.Item(3)
.To = Range("B3")
.cc = Sheets("Mail Ready").Range("B4") & "; " & Sheets("Mail Ready").Range("C4")
.Subject = Range("A1").Value
.HTMLBody = RangetoHTML(rng) & Signature
.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)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
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") & ".html"

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


' Close TempWB.
TempWB.Close savechanges:=False

' Delete the htm file.
Kill TempFile

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