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]

i've sort of worked it out:

Sub sendemail()    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object


  
   
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


        
        With OutMail
            .to = Worksheets("admin").Range("f9")
            .CC = Worksheets("admin").Range("f10")
            .BCC = ""
            .Subject = Worksheets("admin").Range("f11")
            .Body = Worksheets("admin").Range("f12")
                       
            .display
        End With
    


   
End Sub

Hi Michael,

this one fits me, only thing that I need is that macro creates emails as long as there are data in the cells.
I have taken cell A1 as a body, B1 as a title and C1 as an email address.
For example if I have 10 rows filled with data I want to send 10 emails.

I hope this makes sense.

 

[daverunt]

Hi

the basic code would be something like:

Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
      
For Each cell In rng
If cell.Value <> "" Then

Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


        
        With OutMail
            .to = rng.Offset(0,2).value 'column C
            .Subject = rng.Offset(0,1).value 'column B
            .Body = rng.value 'column A
                       
            .display
        'send
        End With


        Set OutMail = Nothing
        Set OutApp = Nothing      
 End If
Next

 

[daverunt]

Sorry, I've put rng.offset and rng.value.

It should be cell.offset(x,x) and cell.value in the To, Subject & Body lines

Tsk.

 

[DachoR]

It works fine
Many thanks!

 

[DachoR]

Sorry, I've put rng.offset and rng.value.

It should be cell.offset(x,x) and cell.value in the To, Subject & Body lines

Tsk.

Hi Daverunt,

would it be possible to make macro to put in one email all data that have to be sent to one person?
For example, if we have cell C1 peter.williams and again in C6 peter.williams, can belonging data be sent in one email instead of two separate emails?

I hope this makes sense.

 

[daverunt]

Hi

There are likely more efficient ways of doing this but none that I can create!
It has changed in that it now works down the email address column C.

You should give this a bit of a test before unleashing it on the actual document.

It uses 2 loops.
Loop1 starts at row 1 and works down, loop2 starts at row 1 + 1 and looks for duplicate email addresses.

Column A - Body
Column B- Subject
Column C - e-mail address - this is the column it works down
Column D - appends a 'yes' when a mail is sent. It checks this column and doesn't send mail if found.
Column D is cleaned when all mails sent.

You might want to change column D if it's in use to another. So 3 appearances of .Offset(0, 1).Value = "yes" would need changing.

Sub Send_Unique()

'Set range for first loop to run down
 Set rng = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp))
          
'Get a row count to clear column D at the end
  x = rng.Rows.Count
 
'Check to see if column D = 'yes' and skip mail if it does
For Each cell In rng
If cell.Value <> "" Then
If Not cell.Offset(0, 1).Value = "yes" Then

NmeRow = cell.Row

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

MailTo = cell.Value 'column C
MailSubject = cell.Offset(0, -1).Value 'column B
MailBody = cell.Offset(0, -2).Value


'Second loop checks the email addresses of all cells following the current cell in the first loop.
'Yes will be appended on any duplicate finds and the mail body detail concatenated
For Each dwn In rng.Offset(NmeRow, 0)

If dwn.Value = cell.Value Then
dwn.Offset(0, 1).Value = "yes"

MailBody = MailBody & vbNewLine & dwn.Offset(0, -2).Value  'column A

End If

Next
        With OutMail
            .To = MailTo
            .Subject = MailSubject
            .Body = MailBody
            .display
        'send
        End With
        
  cell.Offset(0, 1).Value = "yes"
  
  End If
 End If
 
 
MailTo = ""
MailSubject = ""
MailBody = ""
Next

'Clear 'yes' from all appended cells in column D
 Range("D1:D" & x).ClearContents
End Sub

 

[DachoR]

Amazing, works perfectly!

Cheers mate!

 

[daverunt]

Great.
Sorry I was so late responding, I was away from my PC for a few days.

 

[DachoR]

Hi Daverunt,

Is it possible to add one more loop(or anything else) at the end so I can add my signature?
I can write it row by row I just need it separate from these two loops.

 

[daverunt]

Hi,

I wouldn't know how to add it after the mails are created so it would be added inside the loop at the point the mail is created as it is appended to the mail body.

Have a look here.

https://www.mrexcel.com/forum/excel...al-basic-applications-when-sending-email.html

Remember to change to .HTMLBody