Macro - Send an email through Outlook

[giuvilas]

Hi Everyone,

i'm new here i made a research on internet and this is what is mentioned to be the best Excel forum available.
So here I am asking for an advise from some experienced user.

So let's meet the point of this thread..

I need to create a Macro (I'm using Office 2010 Professional + Windows 7 Professional 64bit) in order to send an email (using my Outlook 2010) using all the time the data available on the LAST row of my spreadsheet (of course it's variable, since I'm updating the file on daily basis).

Now, in this row i have the following string that i need to include into the email:

- protocol #
- reference #
- email address

[/URL][/IMG]

The email i want to create it has to be like this:

Mailto: "xyz3@xyz.com"
Subject: "900 - Notification of rejection"

Body of the email:

"Dear customer,

your document "456" has been rejected because blabla..

regards"

I don't want that the macro send automatically the email, since i have to enclose an attachment (i prefer attach the document manually for some reason).

Furthermore i would like to create a rule, that when i'm running the macro is giving me the possibility to chose two (or more) different templates (different subject and body)

I tried the following code modifying the following string in order to take in consideration just the last row:
"Dim r As Integer, x As Double
For r = 2 To 4"

But it didn't work out. I had a pop-up window saying something about shellexecute not found (maybe because i'm using 64bit OS?)

Please help me. It will be really appreciated ..possibly if can share some new code..

The following code is what i tried (with some small modification..

Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _ByVal nShowCmd As Long) As Long
Sub SendEMail() Dim Email As String, Subj As String Dim Msg As String, URL As String Dim r As Integer, x As Double For r = 2 To 4 'data in rows 2-4' Get the email address Email = Cells(r, 2) ' Message subject Subj = "Your Annual Bonus"' Compose the message Msg = "" Msg = Msg & "Dear " & Cells(r, 1) & "," & vbCrLf & vbCrLf Msg = Msg & "I am pleased to inform you that your annual bonus is " Msg = Msg & Cells(r, 3).Text & "." & vbCrLf & vbCrLf Msg = Msg & "William Rose" & vbCrLf Msg = Msg & "President" ' Replace spaces with %20 (hex) Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20") Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20") ' Replace carriage returns with %0D%0A (hex) Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")
' Create the URL URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg ' Execute the URL (start the email client) ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus' Wait two seconds before sending keystrokes Application.Wait (Now + TimeValue("0:00:02")) Application.SendKeys "%s" Next rEnd Sub
Thank you to everyone for the eventual help!

 

[DachoR]

Thanks mate!

Is it possible to add something to code so it can send emails form different shared mailbox addresses to which I have full permissions?

Cheers!

 

[daverunt]

See if this works for you.

https://access-programmers.co.uk/forums/showthread.php?t=226015

 

[DachoR]

You are amazing dude!

Cheers!

 

[spanx_exceluser]

[TABLE="width: 571"]
<colgroup><col><col><col><col><col></colgroup><tbody>[TR]
[TD]Body
[/TD]
[TD]Subject [/TD]
[TD]PLEASE NOTE
[/TD]
[TD]TO [/TD]
[TD]CC[/TD]
[/TR]
[TR]
[TD]XYZS[/TD]
[TD] July - August 2017 [/TD]
[TD]
[/TD]
[TD]unknown@email.com[/TD]
[TD]unknow1 @Email.com[/TD]
[/TR]
[TR]
[TD]abc[/TD]
[TD] July - August 2017 [/TD]
[TD]
[/TD]
[TD]unknown@email.com[/TD]
[TD]unknow1 @Email.com[/TD]
[/TR]
[TR]
[TD]fde[/TD]
[TD] July - August 2017 [/TD]
[TD]
[/TD]
[TD]unknown@email.com[/TD]
[TD]unknow1 @Email.com[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 571"]
<colgroup><col><col><col><col><col></colgroup><tbody>[TR]
[TD]Body[/TD]
[TD]Subject [/TD]
[TD]PLEASE NOTE
[/TD]
[TD]TO [/TD]
[TD]CC[/TD]
[/TR]
[TR]
[TD]XYZS[/TD]
[TD] July - August 2017 [/TD]
[TD]
[/TD]
[TD]unknown@email.com[/TD]
[TD]unknow1 @Email.com[/TD]
[/TR]
[TR]
[TD]abc
[/TD]
[TD] July - August 2017 [/TD]
[TD]
[/TD]
[TD]unknown@email.com[/TD]
[TD]unknow1 @Email.com[/TD]
[/TR]
[TR]
[TD]fde
[/TD]
[TD] July - August 2017 [/TD]
[TD]
[/TD]
[TD]unknown@email.com[/TD]
[TD]unknow1 @Email.com[/TD]
[/TR]
</tbody>[/TABLE]




Sub Mail_Outlook()
Dim OutApp As Object
Dim OutMail As Object

LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

If Cells(LastRow, 1).Value <> "" Then

MailTo = Cells(LastRow, 1).Offset(0, 2).Value

Template = InputBox("Enter the template number to use.", Title:="Enter the Template number")


Select Case Template

Case Is = 1
MailSubject = " - National Brokerage Statement" & Cells(LastRow, 1).Offset(0, 1).Value
MailBody = "Dear Sir / Madam," & vbNewLine & vbNewLine & _
"Awaiting brokerage statement for the month of ." & Cells(LastRow, 1).Value & " and NEFT details if paid." & _
vbNewLine & vbNewLine & "Regards," & vbNewLine & vbNewLine & "Mohsin Khan" & vbNewLine & "(Finance)" & vbNewLine & "Marsh India Insurance Brokers Private Ltd."

Case Is = 2
MailSubject = "You selected 2"
MailBody = "Mail Body 2"
Case Is = 3
MailSubject = "You selected 3"
MailBody = "Mail Body 3"
Case Else
MailSubject = "What!"
MailBody = "What!"
End Select


'Send Mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.Subject = MailSubject
.To = MailTo
.Body = MailBody
'.Attachments.Add FileNme
.Display
'.Send

row_number = 1

Do
DoEvents
row_number = row_number + 1

Loop Until row_number = 6

End With

Set OutMail = Nothing
Set OutApp = Nothing



End If

End Sub





I tried to loop but it doesnt loop and also it does not pick up data as per cells it picks up data as per the last active cell.

Can sm1 please help me i am a novice and would be highly obliged.

 

[daverunt]

Hi,

The original code was for setting up a mail for the last cell only.

Add the range you want and a loop.

Sub Mail_Outlook()
 Dim OutApp As Object
 Dim OutMail As Object

 Set rng = Worksheets("Sheet5").Range("A1:A6")  '------------------------check sheet is right number and range starts from A2:A7 if you are using headers in the first row.

 For Each cell In rng
 If cell.Value <> "" Then

 MailTo = cell.Offset(0, 2).Value '------------------------------------------------ check the offset number is correct from column A

 Template = InputBox("Enter the template number to use.", Title:="Enter the Template number")


 Select Case Template

 Case Is = 1
 MailSubject = " - National Brokerage Statement" & Cells(LastRow, 1).Offset(0, 1).Value
 MailBody = "Dear Sir / Madam," & vbNewLine & vbNewLine & _
 "Awaiting brokerage statement for the month of ." & Cells(LastRow, 1).Value & " and NEFT details if paid." & _
 vbNewLine & vbNewLine & "Regards," & vbNewLine & vbNewLine & "Mohsin Khan" & vbNewLine & "(Finance)" & vbNewLine & "Marsh India Insurance Brokers Private Ltd."

 Case Is = 2
 MailSubject = "You selected 2"
 MailBody = "Mail Body 2"
 Case Is = 3
 MailSubject = "You selected 3"
 MailBody = "Mail Body 3"
 Case Else
 MailSubject = "What!"
 MailBody = "What!"
 End Select


 'Send Mail
 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(o)
 With OutMail
 .Subject = MailSubject
 .To = MailTo
 .Body = MailBody
 '.Attachments.Add FileNme
 .Display
 '.Send

 End With

 Set OutMail = Nothing
 Set OutApp = Nothing

 End If
 Next

 End Sub