Send Mail range to each person

[slamet Harto]

Hi there

Can you advise me if i want to customized email within range as body email.

For example:
I want to send range C2 to I5 for Testuser@test.com then range C6 to I5 to the others and so on.

See attached for your reference.

Thanks in advance.

[Bob Phillips]

Sub SendRangeMail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim i As Integer, RW As Long, LR As Long, rng As Range
Dim cell As Range, MyCell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

With ActiveSheet
RW = .Cells(Rows.Count, 3).End(xlUp).Row
Set rng = Range(.Cells(3, 3), .Cells(RW, 3))

For Each cell In ThisWorkbook.Sheets("Sheet1").Range("C2:I19")

For i = 3 To RW
If .Cells(i, 3) <> "" Then
LR = ActiveSheet.Cells(Rows.Count, 9).End(xlUp).Row + 1
If LR = 3 Then Set rng = Range(.Cells(i, 3).Resize(, 6))
End If
Next
Next
End With
On Error GoTo cleanup

For Each cell In Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)

If cell.Value Like "?*@?*.?*" Then 'And LCase(cell.Offset(0, 1).Value) = "yes" Then

Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail

.To = cell.Value
.Subject = "Reminder"
.HTMLBody = "Dear " & cell.Offset(0, -1).Value & vbNewLine & vbNewLine & RangetoHTML(rng)

'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Send

End With
On Error GoTo 0

Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
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
.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

[slamet Harto]

Hi Bob

Thank you very much for your assistance.

It is getting closer. As my requested, how to set range and copy it (including the header) ?



I want to send range C2 to I5 to TestUser@Test.com, then Range C6 to I15 to Dudut@gmail.com and so on

Once again, thank you for your assistance

[Bob Phillips]

Sub SendRangeMail()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim cell As Range
Dim RW As Long
Dim Lastrow As Long
Dim i As Integer

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

Set OutMail = OutApp.CreateItem(0)

With ActiveSheet

RW = .Cells(Rows.Count, "E").End(xlUp).Row

For Each cell In .Columns("B").Cells(2, 1).Resize(RW - 1).SpecialCells(xlCellTypeConstants)

If cell.Value Like "?*@?*.?*" Then 'And LCase(cell.Offset(0, 1).Value) = "yes" Then

Lastrow = cell.End(xlDown).Row
If Lastrow > RW Then Lastrow = RW + 1
Set rng = cell.Offset(0, 1).Resize(Lastrow - cell.Row, 6)
With OutMail

.To = cell.Value
.Subject = "Reminder"
.HTMLBody = "Dear " & cell.Offset(0, -1).Value & vbNewLine & vbNewLine & RangetoHTML(rng)

'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Send
End With
End If
Next cell
End With

cleanup:
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
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
.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

[slamet Harto]

Bob

Thanks and highly appreciate it.

Have a nice day!!

[slamet Harto]

hi there

another question, can you advise if i want to attach the file?

thanks in advance

[Bob Phillips]

Give it a tr

[slamet Harto]

Hi bob,

thanks for quick response.

I want to endhanced the code given to attach the file after paste range as body mail.

thanks for your assistance

[slamet Harto]

is there any concern? please help

[Bob Phillips]

Just uncomment the Attachments code line Slamet.

[slamet Harto]

Hi bob,

sorry for late reply.
I though, not as simple like that, I got an error "object variable with block are not set"

For Each cell In .Columns("B").Cells(2, 1).Resize(RW - 1).SpecialCells(xlCellTypeConstants)

If cell.Value Like "?*@?*.?*" Then 'And LCase(cell.Offset(0, 1).Value) = "yes" Then

Lastrow = cell.End(xlDown).Row
If Lastrow > RW Then Lastrow = RW + 1
Set rng = cell.Offset(0, 1).Resize(Lastrow - cell.Row, 6)
With OutMail

.To = cell.Value
.Subject = "Reminder"
.HTMLBody = "Dear " & cell.Offset(0, -1).Value & vbNewLine & vbNewLine & RangetoHTML(rng)

'You can add files also like this
.Attachments.Add TempWb.Fullname
.Display 'Or use Send
End With
End If
Next cell
End With


Please advice

[Bob Phillips]

You can't do that, foir two reasons.

The first is that the variable TempWB is local to the function that builds the HTML, and so your procedure knows nothing about a TempWB.

Secondly, the function that builds the HTML kills (deletes) that file pointed to by TempWB.

But why are you trying to attach that, you have its HTML already in the email.

[slamet Harto]

Firstly, If there is any discrepancy between their records and our records then the recipient will simple to add/edit trughout the file rather then copy the body mail and paste into excel.

Secondly, they can read without opening the attachment when they don't have time to reconciled it.

Thanks for your support and assistance.

[Bob Phillips]

I am sorry, I don't understand that statement, or the relevance to what we were discussing.