Create email with filtered data

[OTWarrior]

Hello

I have been asked to create a button in excel, which will generate an email using the data held on a spreadsheet.

Based upon the contents of column B (which is a dropdown) all rows with column B matching the currently selected row, need to be put into a single table within an email. Only certain fields from each row will be needed.

Now, I know how to generate the email based on the current row (and how to put that rows data within the email) but I am unsure how to do this for more than one row at once.

The user is happy to use autofilter to narrow down the to the set criteria. If this is ok, how can I copy the entire visible spreadsheet (only the visible filtered data) into an email as a table.

The code I have thus far is as follows:

[VBA]Public Sub TipsEmail()
Set olApp = CreateObject("Outlook.Application")
Set objMail = olApp.CreateItem(0)
Set objMail = olApp.CreateItem(olMailItem)
Dim tipsSubject As String
Dim tipsBodyText
Dim CurrentCellRow As Long

CurrentCellRow = ActiveCell.Row

tipsSubject = "Tips #" & Range("A" & CurrentCellRow).Text _
& " - " & Range("B" & CurrentCellRow).Text

objMail.Subject = tipsSubject

tipsBodyText = Range("C" & CurrentCellRow).Text

objMail.body = tipsBodyText

objMail.Display

End sub[/VBA]

Thank you

[wakdafak]

[vba]
Sub send_email()
Dim appOutLook As Object
Dim myMailItem As Object
Dim LDate As String
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range

Set sh = Sheets("Franchise Log Sheet")

'frmBodyMail.Show
Call build_email(contact_e_mail, Subject_msg, Mail_Msg)

Application.DisplayAlerts = False
'Sheets("Franchise Log Sheet").Delete
End Sub
Public Sub build_email(contact_e_mail, Subject_msg, Mail_Msg)
Dim appOutLook As Object
Dim myMailItem As Object
Dim LDate As String
Dim sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
'Dim contact_e_mail As String
'Dim Subject_msg As String
'Dim Mail_Msg As String
Dim utils
On Error GoTo Redemption_error
Set utils = CreateObject("Redemption.MAPIUtils")
Set sh = Sheets("Franchise Log Sheet")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
Set contact_e_mail = cell.Value
Set Subject_msg = frmBodyMail.txtSubject & cell.Offset(0, -1).Value
Set Mail_Msg = frmBodyMail.txtBodyMail
Set appOutLook = CreateObject("Outlook.Application")
Set myMailItem = appOutLook.CreateItem(olMailItem)
Set mailOutlook = CreateObject("Redemption.SafeMailItem")
mailOutlook.Item = myMailItem
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set myMailItem = appOutLook.CreateItem(0)
With mailOutlook
.To = cell.Value
.Subject = frmBodyMail.txtSubject & cell.Offset(0, -1).Value
.Body = frmBodyMail.txtBodyMail

For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell

If Sheets("Franchise Log Sheet").Cells(cell.Row, 14).Value <> "" Then
.Send 'Or use Display
End If
End With
End If
Next cell

Set myMailItem = Nothing
'Free Redemption Object
Set mailOutlook = Nothing
Set appOutLook = Nothing
Set myMailItem = Nothing
Set utils = Nothing
Exit Sub
Redemption_error:
erreur = Err
Resume Next

Set appOutLook = Nothing
End Sub[/vba]

just share my work before
i think it should help you

[OTWarrior]

Thanks for that, I will tweak it for my spreadsheet.

Just wondering though, it mentions Redemption. Do I need it installed for this to work?

[wakdafak]

Thanks for that, I will tweak it for my spreadsheet.

Just wondering though, it mentions Redemption. Do I need it installed for this to work?

it is optional

the redemption.dll is used when u want to send the email automaticallay to prevent the outlook warning

because what my macro do is it will send a thousand of email according to the email list in the "Franchise Log Sheet"

it will prevent the outlook warning

[OTWarrior]

I am getting errors on this part

[VBA]Set Mail_Msg = frmBodyMail.txtBodyMail [/VBA]

Where is frmBodyMail defined please? I can't seem to find it.

[wakdafak]

I am getting errors on this part

[vba]Set Mail_Msg = frmBodyMail.txtBodyMail [/vba]

Where is frmBodyMail defined please? I can't seem to find it.

owh i'm sorry
forgot to tell you

you have to create a form
in that form u must have 2 text field that user have to insert the subject and the body of the email and call the "sub send_email()" with a button