PDA

View Full Version : e-mailing macro (with attachment) would like to modify



preseb
02-23-2011, 05:52 AM
I have this get simple macro for sending out files.
Column A - has the persons name - for my reference.
Column B - has their first name - so when it put in the body, it address' them with their first name
Column C is their e-mail
Column D - subject
Column E - is the path and the file to be attached
Column F - body of the message

what I would like to change is, there are a lot of instances where 1 person may recived mutiple reports. The way I am handeling it now is that person woulds get a bunch of e-mails.
I would like to change it so that if a person is to recived multiple attachments, that they would receive 1 e-mail with multiple attachments.

Sub Mailer()
Dim rngMailInfo As Range, rngCell As Range
Dim objApp As Object
Dim objMail As Object
Set rngMailInfo = Intersect(ActiveSheet.UsedRange, Range("B4:F" & Rows.Count))
Set objApp = CreateObject("Outlook.Application")
For Each rngCell In rngMailInfo.Resize(, 1)
On Error Resume Next
Set objMail = objApp.CreateItem(0)
With objMail
.To = rngCell(, 2).Text
.Subject = rngCell(, 3).Text
.Body = "" & rngCell.Text & vbCrLf & rngCell(, 5).Text
.Attachments.Add rngCell(, 4).Text
.Save
End With
Set objMail = Nothing
On Error GoTo 0
Next rngCell
Set objApp = Nothing
End Sub

thank you for your help

slamet Harto
02-23-2011, 08:34 PM
see for your reference
http://www.rondebruin.nl/sendmail.htm (http://www.rondebruin.nl/sendmail.htm)

LeoLee
02-24-2011, 12:24 AM
Not sure if this help

Sub Mail_workbook_Outlook()

Dim OLApp As Outlook.Application
Dim OLMail As Object

Set OLApp = New Outlook.Application
Set OLMail = OLApp.CreateItem(0)

With OLMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "VBA Email Testeing"
.Body = "Hi There"
.Attachments.Add ("C:\Users\file" ++ more attachment u want )
.Send
End With


Set OLMail = Nothing
Set OLApp = Nothing

End Sub

LeoLee
02-24-2011, 01:06 AM
I am sorry, please ignore my previous post. Copied and pasted the wrong VBA code. Moderator, if is possible, please help me to delete the previous post. Thank you.

I hope this help:

Sub Mailer()
Dim rngMailInfo As Range, rngCell As Range
Dim objApp As Object
Dim objMail As Object

Dim X As Long
Dim A As String

Set rngMailInfo = Intersect(ActiveSheet.UsedRange, Range("B4:F" & Rows.Count))

Set objApp = CreateObject("Outlook.Application")

For Each rngCell In rngMailInfo.Resize(, 1)

On Error Resume Next

Set objMail = objApp.CreateItem(0)

With objMail
.To = rngCell(, 2).Text
.Subject = rngCell(, 3).Text
.Body = "" & rngCell.Text & vbCrLf & rngCell(, 5).Text

X = 3 '(Begin with which row?)

Do while worksheets("sheet1").cell(X,5) <> ""

A = worksheets("sheet1").cell( X ,5)
.Attachments.Add (A)

X = X + 1

End With

Set objMail = Nothing

On Error GoTo 0

Next rngCell

Set objApp = Nothing

End Sub
Please change worksheets("sheet1").cell(x, 5 ) and value of X to your specific location of the path of attachment. (Colum E)

I use a Do While loop to check if Column E have multiple Path link.

Ps: I havent do a extensive testing to see any other error in your code.