View Full Version : Send Mail range to each person
slamet Harto
12-06-2010, 03:18 AM
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
12-06-2010, 06:51 AM
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
12-06-2010, 10:13 AM
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
12-06-2010, 11:02 AM
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
12-06-2010, 05:58 PM
Bob
Thanks and highly appreciate it.
Have a nice day!!
slamet Harto
12-09-2010, 02:10 AM
hi there
another question, can you advise if i want to attach the file?
thanks in advance
Bob Phillips
12-09-2010, 02:55 AM
Give it a tr
slamet Harto
12-09-2010, 04:12 AM
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
12-10-2010, 12:53 AM
is there any concern? please help
Bob Phillips
12-11-2010, 06:07 AM
Just uncomment the Attachments code line Slamet.
slamet Harto
12-13-2010, 02:53 AM
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
12-13-2010, 03:07 AM
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
12-13-2010, 03:58 AM
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
12-14-2010, 02:52 AM
I am sorry, I don't understand that statement, or the relevance to what we were discussing.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.