• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Sending an Email with VBA code that auto populates address and subject

A

Andrew D

New Member
Hi All,


I am using the following piece of VBA code in Excel 2007 to automatically generate an email when a button is pushed:


Sub SendEMail()

Dim Email As String, Subj As String

Dim Msg As String, URL As String

Dim r As Integer, x As Double

r = ActiveCell.Row

'Get the email address

Email = Cells(r, 3)

'Message subject

Subj = Cells(r, 6)

'Compose the message

Msg = ""

Msg = Msg & Cells(r, 7) & "," & vbCrLf & vbCrLf

'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"

End Sub


The button to launch this code sits in cell AK7. What I would like to do is have the macro copy the email address present in cell E7 into the email address section of my created email. In addition I would like the reference provided in cell AJ7 to appear in the Message Subject part of the generated email in the format " RCS Reference contents of cell AJ7"


Any help would be really great.


Thanks.
 
I think this should do it:

[pre]
Code: 
Sub SendEMail()
Dim Email As String, Subj As String
Dim Msg As String, URL As String
Dim r As Integer, x As Double
r = ActiveCell.Row
'Get the email address
Email = Range("E7").Value
'Message subject
Subj = Range("AJ7").Value
'Compose the message
Msg = ""
Msg = Msg & Cells(r, 7) & "," & vbCrLf & vbCrLf
'Replace spaces with %20 (hex)
Subj = "RCS " & Subj
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"
End Sub
[/pre]
 
I have one final question...


This macro runs when a user hits a button at the end of a row of data relating to an individual user request. This then emails the result of the request back to the requestor.


As more requests come in they will add in the rows below Row 1 . Rather than assign different macro buttons to each row is there an easier way to have the macro look at each row?


The main criteria is


1. macro must be manually ran

2. The macro will always look along the specified row to find the correct email address and reference code to email.


Thanks again,


Andrew
 
You might want to consider using a trigger event rather than a regular macro. Let's say we setup col AK to be the "trigger" column. Right-click on sheet tab, view code. This will access the sheet module. Paste this in

[pre]
Code: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim Email As String, Subj As String
Dim Msg As String, URL As String
Dim r As Integer, x As Double

'Which column is being used as trigger?
If Intersect(Range("AK:AK"), Target) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub 'In case multiple cells are selected
r = Target.Row
'Get the email address
Email = Cells(r, "E").Value
'Message subject
Subj = Cells(r, "AJ").Value
'Compose the message
Msg = ""
Msg = Msg & Cells(r, 7) & "," & vbCrLf & vbCrLf
'Replace spaces with %20 (hex)
Subj = "RCS " & Subj
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"
Cancel = True 'Prevents editing of cell
End Sub
[/pre]
This macro will not get triggered if you double-click in col AK. It's also setup to take data from whatever row you double clicked on.
 
Hi Luke,


I've pasted in the code above but when i double click on a cell in col AK a timer appears but nothing happens. Have I missed something obvious?


Thanks again for your help
 
Oops, I forgot I commented out your command line while working on my machine.

Code: 
'ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus

Remove the single apostrophe, then we should be back in business. My apologies.
 
Hi,


I've removed the apostrophe and when I run the code I get a compile error: Sub or Function not defined.


Sorry to be a pain.
 
I'm assuming the ShellExecute is another macro you have somewhere? Make sure that the macro for it is not private. If error persists and ShellExecute is public, try changing the one line to

Code: 
Call ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus
 
Hi,


Apologies I hadn't copied in the start of the code. Should have read:


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

r = ActiveCell.Row

'Get the email address

Email = Range("E7").Value

'Message subject

Subj = Range("AJ7").Value

'Compose the message

Msg = ""

Msg = Msg & Cells(r, 7) & "," & vbCrLf & vbCrLf

'Replace spaces with %20 (hex)

Subj = "RCS " & Subj

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"

End Sub
 
Ah ha! Yeah, you'll want to move this

[pre]
Code: 
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
[/pre]
to the sheet module as well (with the macro). They need to both be on the same module.
 
You must log in or register to reply here.
Back
Top