Hi Experts
I need to send a Lotus Notes email from VBA code within my Excel spreadsheet that can be read on mobile phones such as the Blackberry.
A range of cells from my spreadsheet are copied and pasted on the clipboard and then pasted (with the same spreadsheet formatting) in the body of the email. Note I need to keep the spreadsheet formatting in my email.
I am using the code below which works but the email can't be read on a Blacbberry phone because it is an image. I need to be able to paste special in the body of my email as rich text. That is, I need to be able to code the following manual steps:
Select the Edit Menu Item in Notes
Select Paste Special
Select Rich Text
Click OK
Note the code below was put together with the use of existing code in the spreadsheet I inherited from my predecessors and with the help of Seppo Sinisaari in Finland.
Your urgent response will be much appreciated. I look forward to hearing from you.
--------------------------
----------
----------
----------
----------
----------
----------
----------
----------
----------
----------
----------
-
Option Explicit
Function SendEMail(SheetName As String, EmailBody As String, EmailSubject As String, MyAttachment As String)
Application.DisplayAlerts = False
On Error GoTo ErrorMsg
Dim EmailList As Variant
Dim ws, uidoc, session, db, uidb, NotesAttach, NotesDoc As Object
Dim RichTextBody, RichTextAttachment As Object
Dim StyleBold, StyleNorm, StyleUnderline, StyleFont10 As Object
Dim server, mailfile, user, usersig As String
Dim SubjectTxt, MsgTxt As String
Dim data
Dim group1, group2, group3 As String
'The email groups are contained in a named range in my worksheet. I create an email list
'from these named ranges
group1 = Range("EmailList1")
group2 = Range("EmailList2")
EmailList = Array(group1, group2)
Set ws = CreateObject("Notes.NotesU
IWorkspace
")
Set session = CreateObject("Notes.NotesS
ession")
user = session.UserName
usersig = session.CommonUserName
server = session.GetEnvironmentStri
ng("MailSe
rver", True)
mailfile = session.GetEnvironmentStri
ng("MailFi
le", True)
Set db = session.GetDatabase(server
, mailfile)
Set uidb = ws.CURRENTDATABASE
Set NotesDoc = db.createdocument
Set RichTextBody = NotesDoc.CreateRichTextIte
m("Body")
'Attach spreadsheet
If MyAttachment <> "" Then
Set RichTextAttachment = NotesDoc.CreateRichTextIte
m("Attachm
ent")
Set NotesAttach = RichTextAttachment.EmbedOb
ject(1454,
"", MyAttachment)
End If
NotesDoc.Subject = EmailSubject 'The subject line in the email
NotesDoc.SendTo = user 'I send the email to myself
NotesDoc.CopyTo = EmailList ' Others that I send the email to
Set uidoc = ws.EDITDOCUMENT(True, NotesDoc)
Sheets(SheetName).Select
Sheets(SheetName).Range(Em
ailBody).S
elect
Selection.Copy 'Picture Appearance:=xlScreen, Format:=xlPicture
Call uidoc.GOTOFIELD("Body")
Call uidoc.Paste 'CAN I PASTE SPECIAL
Call uidoc.Save
'I commented this out because I get a msg box asking me if I want to save and send,
'send only, discard or cancel changes and I don't know how to get rid of the msg box
'Call uidoc.Close(True)
Set NotesDoc = uidoc.DOCUMENT
Call NotesDoc.Save(True, True)
'This has to be set to False or we get errors
NotesDoc.SAVEMESSAGEONSEND
= False
'Keep this set to false.
NotesDoc.SEND False
'*************************
**********
**********
**********
**********
**********
**********
*
'This piece has been added to get around the problem of stopping the clear clipboard
'prompt'
Sheets("Email Message").Select
Sheets("Email Message").Range("A1").Sele
ct
Selection.Copy
'*************************
**********
**********
**********
**********
**********
**********
*
Set session = Nothing 'close connection to free memory
Set db = Nothing
Set NotesAttach = Nothing
Set NotesDoc = Nothing
Set uidoc = Nothing
Set ws = Nothing
Exit Function
ErrorMsg: If Err.Number = 7225 Then
MsgBox "The file " & Range("Fname_NZ_VaR") & " cannot be found in the location " & _
Range("Path_NZ_VaR"), vbOKOnly, "Error"
ElseIf Err.Number = 1004 Then
MsgBox "One of the following may be causing an error:" & vbCrLf & _
"1. The range 'Path_NZ_VaR' and/or 'Fname_NZ_VaR' does not exist in this spreadsheet," & _
vbCrLf & "2. The range 'Fname_NZ_VaR' does not contain a filename," & vbCrLf _
& "3. The path " & Range("Path_NZ_VaR") & " does not exist.", vbOKOnly, "Error"
Else
MsgBox Err.Number & Err.Description
End If
End Function
I call the function as follows:
Call SendNotesMail.SendEMail("M
ktCommenta
ry", "Email", "Wellington Risk Roundup - " & Format(Now(), "mmm d yyyy"), "")
