Copy/Paste to email
 

I use the code below (which someone out there kindly sent to me) to put a
range into an email message.
The problem is that I have to "paste" into the body of the email.
Can someone supply code that does this automatically,
"Public Sub SendEMailByURL()
Dim vURL As String
Dim vEmail As String
Dim vSubj As String
Dim vMsg As String
Dim vTitleEmail As String
Dim i As Long
Dim vShell
'Copy range selection to paste
Range("a8:p18").Copy
'Email data
vEmail = "
vSubj = "Raukawa"
vMsg = " "
vTitleEmail = vSubj
'Spaces to hexdecimal
vSubj = Application.WorksheetFunction.Substitute(vSubj, " ", "%20")
vMsg = Application.WorksheetFunction.Substitute(vMsg, " ", "%20")
'Carriage Returns to hexdecimal
vMsg = Application.WorksheetFunction.Substitute(vMsg, vbCrLf, "%0D%0A")
vURL = "mailto:" & vEmail & "?subject=" & vSubj & "&body=" & vMsg
'Shell the Windows Start
vShell = Shell(Left("Start " & vURL, 460), vbHide)
'Wait window email before sending keystrokes
WaitEmail:
On Error Resume Next
i = i + 1
Application.Wait (Now + TimeValue("0:00:01"))
AppActivate vTitleEmail 'Verify your title email
If Err.Number < 0 And i < 30 Then GoTo WaitEmail
Application.SendKeys "{TAB}{TAB}{TAB}{TAB}~^v"
Application.Wait (Now + TimeValue("0:00:01"))
End Sub"

Barry

Copy/Paste to email
 

hi,
see this web site.
http://www.rondebruin.nl/sendmail.htm
ron knows a thing or 2 about emailing from xl.
good luck.

-----Original Message-----
I use the code below (which someone out there kindly sent
to me) to put a
range into an email message.
The problem is that I have to "paste" into the body of
the email.
Can someone supply code that does this automatically,
"Public Sub SendEMailByURL()
Dim vURL As String
Dim vEmail As String
Dim vSubj As String
Dim vMsg As String
Dim vTitleEmail As String
Dim i As Long
Dim vShell
'Copy range selection to paste
Range("a8:p18").Copy
'Email data
vEmail = "
vSubj = "Raukawa"
vMsg = " "
vTitleEmail = vSubj
'Spaces to hexdecimal
vSubj = Application.WorksheetFunction.Substitute
(vSubj, " ", "%20")
vMsg = Application.WorksheetFunction.Substitute
(vMsg, " ", "%20")
'Carriage Returns to hexdecimal
vMsg = Application.WorksheetFunction.Substitute(vMsg,
vbCrLf, "%0D%0A")
vURL = "mailto:" & vEmail & "?subject=" & vSubj
& "&body=" & vMsg
'Shell the Windows Start
vShell = Shell(Left("Start " & vURL, 460), vbHide)
'Wait window email before sending keystrokes
WaitEmail:
On Error Resume Next
i = i + 1
Application.Wait (Now + TimeValue("0:00:01"))
AppActivate vTitleEmail 'Verify your title email
If Err.Number < 0 And i < 30 Then GoTo WaitEmail
Application.SendKeys "{TAB}{TAB}{TAB}{TAB}~^v"
Application.Wait (Now + TimeValue("0:00:01"))
End Sub"

Barry


.