Ron de Bruin gave me a mail merge that works perfectly- but would like to
include "conditions" text at bottom of each mail- any idea how to do this
automatically
--
Thanks for your help

Hi David

Maybe this will help you
http://www.rondebruin.nl/mail/folder3/signature.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"David" wrote in message ...
Ron de Bruin gave me a mail merge that works perfectly- but would like to
include "conditions" text at bottom of each mail- any idea how to do this
automatically
--
Thanks for your help

Ron,

Don't know wher to insert the signature bit to the mail merge you already
gave- can you help- code I'm using below

Thanks again,

David

Sub Send_Row_Or_Rows_1()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim StrBody As String

'With Selection.Font
'.Name = "Arial"
'.Size = 10


StrBody = "Please find below payments currently being processed on your
behalf." & "<br" & _
"Receipt of funds will vary considerably depending on your
final destination bank and the financial intermediaries used along the way."
& "<br" & _
"For all payment queries logon to www.paymentconnexions.com or reply to this
email." & "<br" & _
"For all Technical Emergencies call +1-416-801-6648." & "<br" & _
" " & "<br" & _
"Kind Regards- Wirecard Payment Solutions Limited." & "<br" & _
" " & "<br" & _
"This e-mail and any files transmitted with it are confidential and
intended solely for the use of the individual or entity to whom they are
addressed. If you have received this e-mail in error please notify the
sender & delete from your system. The recipient should check this e-mail and
any attachments for the presence of viruses. The company accepts no
liability for any damage caused by any virus transmitted by this e-mail." &
"<br<br"



On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A16:f" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1 ))

StrBody = "Please find below payments currently being processed on your
behalf." & "<br" & _
"Receipt of funds will vary considerably depending on your
final destination bank and the financial intermediaries used along the way."
& "<br" & _
"For all payment queries logon to www.paymentconnexions.com or reply to this
email." & "<br" & _
"For all Technical Emergencies call +1-416-801-6648." & "<br" & _
" " & "<br" & _
"Kind Regards- Wirecard Payment Solutions Limited." & "<br" & _
" " & "<br" & _
"This e-mail and any files transmitted with it are confidential and
intended solely for the use of the individual or entity to whom they are
addressed. If you have received this e-mail in error please notify the
sender & delete from your system. The recipient should check this e-mail and
any attachments for the presence of viruses. The company accepts no
liability for any damage caused by any virus transmitted by this e-mail." &
"<br<br"

'If there are unique values start the loop
If Rcount = 2 Then
For Rnum = 2 To Rcount

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value

'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:B" & _
Worksheets("Mailinfo").Rows.Count), 2, False)
On Error GoTo 0

If mailAddress < "" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.to = mailAddress
.Subject = Worksheets("Mailinfo").Range("e3")
'.Subject = "Test mail2"
.HTMLBody = StrBody & RangetoHTML(rng)
'.Signature = "Mercant Pmt"
.display 'Or use Send or Display

End With
On Error GoTo 0

Set OutMail = Nothing
End If

'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub



"Ron de Bruin" wrote:

Hi David

Maybe this will help you
http://www.rondebruin.nl/mail/folder3/signature.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"David" wrote in message ...
Ron de Bruin gave me a mail merge that works perfectly- but would like to
include "conditions" text at bottom of each mail- any idea how to do this
automatically
--
Thanks for your help

See example 2 on the page how you can add it below the html text in the mail

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"David" wrote in message ...
Ron,

Don't know wher to insert the signature bit to the mail merge you already
gave- can you help- code I'm using below

Thanks again,

David

Sub Send_Row_Or_Rows_1()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim StrBody As String

'With Selection.Font
'.Name = "Arial"
'.Size = 10


StrBody = "Please find below payments currently being processed on your
behalf." & "<br" & _
"Receipt of funds will vary considerably depending on your
final destination bank and the financial intermediaries used along the way."
& "<br" & _
"For all payment queries logon to www.paymentconnexions.com or reply to this
email." & "<br" & _
"For all Technical Emergencies call +1-416-801-6648." & "<br" & _
" " & "<br" & _
"Kind Regards- Wirecard Payment Solutions Limited." & "<br" & _
" " & "<br" & _
"This e-mail and any files transmitted with it are confidential and
intended solely for the use of the individual or entity to whom they are
addressed. If you have received this e-mail in error please notify the
sender & delete from your system. The recipient should check this e-mail and
any attachments for the presence of viruses. The company accepts no
liability for any damage caused by any virus transmitted by this e-mail." &
"<br<br"



On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A16:f" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1 ))

StrBody = "Please find below payments currently being processed on your
behalf." & "<br" & _
"Receipt of funds will vary considerably depending on your
final destination bank and the financial intermediaries used along the way."
& "<br" & _
"For all payment queries logon to www.paymentconnexions.com or reply to this
email." & "<br" & _
"For all Technical Emergencies call +1-416-801-6648." & "<br" & _
" " & "<br" & _
"Kind Regards- Wirecard Payment Solutions Limited." & "<br" & _
" " & "<br" & _
"This e-mail and any files transmitted with it are confidential and
intended solely for the use of the individual or entity to whom they are
addressed. If you have received this e-mail in error please notify the
sender & delete from your system. The recipient should check this e-mail and
any attachments for the presence of viruses. The company accepts no
liability for any damage caused by any virus transmitted by this e-mail." &
"<br<br"

'If there are unique values start the loop
If Rcount = 2 Then
For Rnum = 2 To Rcount

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value

'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:B" & _
Worksheets("Mailinfo").Rows.Count), 2, False)
On Error GoTo 0

If mailAddress < "" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.to = mailAddress
.Subject = Worksheets("Mailinfo").Range("e3")
'.Subject = "Test mail2"
.HTMLBody = StrBody & RangetoHTML(rng)
'.Signature = "Mercant Pmt"
.display 'Or use Send or Display

End With
On Error GoTo 0

Set OutMail = Nothing
End If

'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub



"Ron de Bruin" wrote:

Hi David

Maybe this will help you
http://www.rondebruin.nl/mail/folder3/signature.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"David" wrote in message ...
Ron de Bruin gave me a mail merge that works perfectly- but would like to
include "conditions" text at bottom of each mail- any idea how to do this
automatically
--
Thanks for your help

Ron,
Sorry for this but don't know what bit from example 2 do I bring into the
code that enclosed on an earlier post. Any chance you could copy code in for
me.
Would be really sppreciated- if not thanks for your help so far

David
--


"Ron de Bruin" wrote:

See example 2 on the page how you can add it below the html text in the mail

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"David" wrote in message ...
Ron,

Don't know wher to insert the signature bit to the mail merge you already
gave- can you help- code I'm using below

Thanks again,

David

Sub Send_Row_Or_Rows_1()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim StrBody As String

'With Selection.Font
'.Name = "Arial"
'.Size = 10


StrBody = "Please find below payments currently being processed on your
behalf." & "<br" & _
"Receipt of funds will vary considerably depending on your
final destination bank and the financial intermediaries used along the way."
& "<br" & _
"For all payment queries logon to www.paymentconnexions.com or reply to this
email." & "<br" & _
"For all Technical Emergencies call +1-416-801-6648." & "<br" & _
" " & "<br" & _
"Kind Regards- Wirecard Payment Solutions Limited." & "<br" & _
" " & "<br" & _
"This e-mail and any files transmitted with it are confidential and
intended solely for the use of the individual or entity to whom they are
addressed. If you have received this e-mail in error please notify the
sender & delete from your system. The recipient should check this e-mail and
any attachments for the presence of viruses. The company accepts no
liability for any damage caused by any virus transmitted by this e-mail." &
"<br<br"



On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A16:f" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1 ))

StrBody = "Please find below payments currently being processed on your
behalf." & "<br" & _
"Receipt of funds will vary considerably depending on your
final destination bank and the financial intermediaries used along the way."
& "<br" & _
"For all payment queries logon to www.paymentconnexions.com or reply to this
email." & "<br" & _
"For all Technical Emergencies call +1-416-801-6648." & "<br" & _
" " & "<br" & _
"Kind Regards- Wirecard Payment Solutions Limited." & "<br" & _
" " & "<br" & _
"This e-mail and any files transmitted with it are confidential and
intended solely for the use of the individual or entity to whom they are
addressed. If you have received this e-mail in error please notify the
sender & delete from your system. The recipient should check this e-mail and
any attachments for the presence of viruses. The company accepts no
liability for any damage caused by any virus transmitted by this e-mail." &
"<br<br"

'If there are unique values start the loop
If Rcount = 2 Then
For Rnum = 2 To Rcount

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value

'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:B" & _
Worksheets("Mailinfo").Rows.Count), 2, False)
On Error GoTo 0

If mailAddress < "" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.to = mailAddress
.Subject = Worksheets("Mailinfo").Range("e3")
'.Subject = "Test mail2"
.HTMLBody = StrBody & RangetoHTML(rng)
'.Signature = "Mercant Pmt"
.display 'Or use Send or Display

End With
On Error GoTo 0

Set OutMail = Nothing
End If

'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub



"Ron de Bruin" wrote:

Hi David

Maybe this will help you
http://www.rondebruin.nl/mail/folder3/signature.htm


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"David" wrote in message ...
Ron de Bruin gave me a mail merge that works perfectly- but would like to
include "conditions" text at bottom of each mail- any idea how to do this
automatically
--
Thanks for your help