Paste a range of cells in the body of an email

[Qreeree]

I have been trying to get the code to work for copying a range of cells and
pasting it into the body of an email

I am using excel 2007 and Lotus Notes 7.0.2

My current code works kinda sorta.
It will copy and paste the text into the body of an email.
But it does not open a new email it replys to a email that is in my in box.
It also sends an email but it is a blank email.

I would do just an attachment but the department I need to send the email to
says they can not open the attachment...........

Anyone have code that can do this?

thanks
Marie

 

[Gord Dibben]

All you ever need to know about emailing from Excel can be found at Ron de
Bruin's site.

http://www.rondebruin.nl/sendmail.htm

Note the free Sendmail Add-in to make your life easier.


Gord Dibben MS Excel MVP

 

[Qreeree]

I have seen this before and it is super super helpful. My problem is that
the example that deals with pasting a range of cells into the body of an
email uses outlook. I have tried editing the macro to work with Notes but no
luck. I have added the Ron's email add-ins but they use outlook not Lotus
Notes and my work uses Lotus Notes. I have tried to use Outlook with my
Lotus Notes but it just made a real mess of things and I ended up not being
able to open my emails in either one.

Thanks
Marie

 

[Gord Dibben]

Apologies.

I had no investigated far enough on which email clients Ron's code works
best or not at all.


Gord

 

[Qreeree]

Here is the code I am using. I found this somewhere on the net and I can't
find it again......It does the copy paste part perfect. the part it doesn't
do is send it to the correct person. It replies to an email in my in box
instead of creating a new email. Sorry if the ciode is a mess but I am new
at this and I was getting help from co-workers who are a little more
expierenced but they are stummped too


Thanks

Sub CopyRange()
' setting up various objects
Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim EmbedObj1 As Object
Dim recipient As String
Dim ccRecipient As String
Dim bccRecipient As String
Dim subject As String
Dim bodytext As String
Dim Attachment1 As String
'Dim t1 As Range

t1 = Range("body")






' setting up all sending recipients
recipient = "(e-mail address removed)"
ccRecipient = ""
bccRecipient = ""
subject = "Excel to Lotus Test Mail"
bodytext = "Testing this.."



'// Lets check to see if form is filled in Min req =Recipient, Subject,
Body Text
If recipient = vbNullString Or subject = vbNullString Or bodytext =
vbNullString Then
MsgBox "Recipient, Subject and or Body Text is NOT SET!",
vbCritical + vbInformation
Exit Sub
End If

' creating a notes session
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) -
InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GETDATABASE("", MailDbName)

If Maildb.IsOpen <> True Then
On Error Resume Next
Maildb.OPENMAIL
End If

Set MailDoc = Maildb.CreateDocument
MailDoc.Form = "Memo"

' loading the lotus notes e-mail with the inputed data
With MailDoc
.SendTo = recipient
.copyto = ccRecipient
.blindcopyto = bccRecipient
.subject = subject
.body = bodytext


End With

' saving message
MailDoc.SaveMessageOnSend = True

Attachment1 = ""
If Attachment1 <> "" Then
Set AttachME = MailDoc.CREATERICHTEXTITEM(Range("A1"))
Set EmbedObj1 = AttachME.EmbedObject(1454, "", Range("A1"),
"Attachment")
MailDoc.CREATERICHTEXTITEM ("Attachment")
End If


' send e-mail !!!!
MailDoc.PostedDate = Now()
' if error in attachment or name of recipients
On Error GoTo errorhandler1
Range("body").Select
Selection.Copy
Set ws = CreateObject("Notes.NotesUIWorkspace")
If Not ws Is Nothing Then
Set uidoc = ws.editdocument(True)
If Not uidoc Is Nothing Then
If uidoc.editmode Then
Call uidoc.gotofield("Body")
Call uidoc.Paste
End If
End If
End If


'MailDoc.send 0, recipient

Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Range("A1")


'Unload Me
Exit Sub
' setting up the error message
errorhandler1:
MsgBox "Incorrect name supplied or the attachment has not attached," & _
"or your Lotus Notes has not opened correctly. Recommend you open up
Lotus Notes" & _
"to ensure the application runs correctly and that a vaild connection
exists"

Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
' unloading the userform
'Unload Me
'saving data to external database
'linecount Macro
' Macro recorded 3/23/2010 by tb2841
'

End Sub

 

[lin Lin]

Private Sub CommandButton1_Click()
Dim recip As Variant
Dim Notes As Object, db As Object, WorkSpace As Object
Dim UIDoc As Object, UserName As String, MailDbName As String
Dim AttachMe As Object, EmbedObj As Object, NotesStyle As Object
Dim rtitem As Object

recip = ActiveWorkbook.ActiveSheet.Range("aa2", ActiveSheet.Range("aa65536").End(xlUp)).Value
For i = 1 To UBound(recip)
Str_recip = Str_recip & recip(i, 1) & " ,"
'MsgBox Str_recip
Next

Set Notes = CreateObject("Notes.NotesSession")

UserName = Notes.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, _
(Len(UserName) - InStr(1, UserName, " "))) & ".nsf"

Set db = Notes.GetDatabase(vbNullString, MailDbName)

Set WorkSpace = CreateObject("Notes.NotesUIWorkspace")
Call WorkSpace.ComposeDocument(, , "Memo")

Set UIDoc = WorkSpace.CurrentDocument

Call UIDoc.FieldSetText("enterCopyTo", Str_recip) 'Recipient
Call UIDoc.FieldSetText("Subject", "Please Review")

ActiveWorkbook.ActiveSheet.Range("a1", ActiveSheet.Range("v65536").End(xlUp)).CopyPicture

'Range([c16], [x65536].End(3)).CopyPicture
Call UIDoc.GoToField("Body")

Call UIDoc.InsertText(WorksheetFunction.Substitute( _
"Good day!@@TEST....This week's resolved incidents; at your earliest convenience, please close@", _
"@", vbCrLf))
'Attachment test
'Add Attachemnt file to email if passed

Set AttachMe = UIDoc.Document.CreateRichTextItem("Attachment")
Set EmbedObj = AttachMe.EmbedObject(1454, _
vbNullString, "C:\Documents and Settings\ExcelAtt\Desktop\ThisAtt.xls", "Attachment")
Call UIDoc.Paste
Call UIDoc.InsertText(Application.Substitute( _
"@@Thank you!", "@", vbCrLf))
Application.CutCopyMode = False

'Call UIdoc.Send(False)
UIDoc.Close

Set UIDoc = Nothing: Set WorkSpace = Nothing
Set db = Nothing: Set Notes = Nothing

End Sub