Excel V5.0 to Lotus Notes 4.5

[DaveSwanton77]

I have written a procedure in excel that produces reports and then save them in separate files. Is there any way I could create a lotus notes e-mail and send them from Excel?

[Asala42]

I 2nd that request,

I used to have a co-worker that claimed he managed to do this (so I guess it's possible anyway). I've never been able to scrounge that code from him though - and I haven't been able to figure it out myself (I'm still on the beginner end of the VBA spectrum).

Please post if you're a Lotus Notes user who has tried to do this.

Adam

[Jay Petrulis]

Here is the code that I use. I had to change a few things before I could post it, so please report back any problems.

Put the Declare Function statement at the top of the module, after the Option Explicit (if used) and before any other routines.

The code will prompt you to enter the e-mail addresses of the recipients, separated by a comma, although that can be changed to looping through a list on a worksheet, for example.

I have this set up to send to up to 14-15 recipients (including groups). I originally had the code read the mailing list into an array, but the "mail to" wouldn't read the whole array correctly, so I forced it into an If-Then-Else structure.

Note, this code saves the workbook with a concatenation of three cells on the sheet (active sheet I believe, as my program copies one sheet from a file to a new workbook). Please change that to suit your requirements (where I set strfilename to the value of 3 cells in the sheet).

Finally, the workbook also mails to the user's login name. If you are not on a network, then be careful there, although I don't know any people who have Lotus Notes on their home computer.

------------------------------
Private Declare Function apiGetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nsize As Long) As Long


Private Sub mail_report()
Dim strfilename As String
Dim mail_list As String, x As Integer
Dim Position() As Integer
Dim NameList() As String
Dim strNameCt As Integer

' be sure to reference the Lotus Domino Objects, domobj.tlb
Dim objNotesSession As Object
Dim objNotesDatabase As Object
Dim objNotesDocument As Object
Dim objAttachment As Object
Dim objRichText As Object
Dim FullPath As String
Dim FileName As String
Dim Msg As String

Const EMBED_ATTACHMENT = 1454

Set objNotesSession = CreateObject("Notes.Notessession")
Set objNotesDatabase = objNotesSession.GetDatabase("", "")
Call objNotesDatabase.OpenMail 'default mail database
If objNotesDatabase.IsOpen = False Then
MsgBox "Cannot connect to Lotus Notes."
Exit Sub
End If
Set objNotesDocument = objNotesDatabase.CreateDocument
Call objNotesDocument.ReplaceItemValue("Form", "Memo")

mail_list = Application.InputBox("Enter the e-mail address of your" & vbCr & "recipient(s)." & vbCr & vbCr & "For multiple recipients, please separate" & vbCr & "the e-mail addresses with a comma.", "Send file")
If IsEmpty(mail_list) Then Exit Sub
If mail_list = "" Then Exit Sub
If mail_list = "False" Then Exit Sub
Msg = Application.InputBox("Enter a brief message (not required)" & vbCr & "to be added to the message text.", "Add a cheerful greeting!")
If Msg = "False" Then Msg = ""
strNameCt = Len(mail_list) - Len(WorksheetFunction.Substitute(mail_list, ",", "")) + 1

Application.ScreenUpdating = False
ChDrive "C"
ChDir "C:Excel"

If strNameCt = 1 Then GoTo Send_The_File

ReDim Position(1 To strNameCt - 1)
For x = 1 To strNameCt - 1
If x = 1 Then
Position(x) = WorksheetFunction.Search(",", mail_list, 1)
Else
Position(x) = WorksheetFunction.Search(",", mail_list, Position(x - 1) + 1)
End If
Next x
ReDim NameList(1 To strNameCt)
For x = 1 To strNameCt
If x = 1 Then
NameList(x) = Left(mail_list, Position(x) - 1)
ElseIf x = strNameCt Then
NameList(x) = Right(mail_list, Len(mail_list) - Position(x - 1) - 1)
Else
NameList(x) = Mid(mail_list, Position(x - 1) + 1, Position(x) - Position(x - 1) - 1)
End If
Next x

Send_The_File:
Application.DisplayAlerts = False
With ActiveWorkbook
Range("A1").Select
strfilename = Cells(1, 3) & " " & Cells(2, 3) & " " & Cells(3, 3).Text
.SaveAs FileName:=strfilename
End With
Application.DisplayAlerts = True
' assemble message
Set objRichText = objNotesDocument.CreateRichTextItem("Body")
Set objAttachment = objRichText.EmbedObject(EMBED_ATTACHMENT, "", ActiveWorkbook.FullName, strfilename)
Msg = Msg & vbCr & vbCr & "Report sent by " & objNotesSession.CommonUserName
With objNotesDocument
.Subject = strfilename
.Body = Msg
If strNameCt = 1 Then
.SendTo = Array(mail_list, fOSUserName)
ElseIf strNameCt = 2 Then
.SendTo = Array(NameList(1), NameList(2), fOSUserName)
ElseIf strNameCt = 3 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), fOSUserName)
ElseIf strNameCt = 4 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), fOSUserName)
ElseIf strNameCt = 5 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), fOSUserName)
ElseIf strNameCt = 6 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), fOSUserName)
ElseIf strNameCt = 7 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), NameList(7), fOSUserName)
ElseIf strNameCt = 8 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), NameList(7), NameList(8), fOSUserName)
ElseIf strNameCt = 9 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), fOSUserName)
ElseIf strNameCt = 10 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), NameList(10), fOSUserName)
ElseIf strNameCt = 11 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), NameList(10), NameList(11), fOSUserName)
ElseIf strNameCt = 12 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), _
NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), _
NameList(10), NameList(11), NameList(12), fOSUserName)
ElseIf strNameCt = 13 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), _
NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), _
NameList(10), NameList(11), NameList(12), NameList(13), fOSUserName)
ElseIf strNameCt = 14 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), _
NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), _
NameList(10), NameList(11), NameList(12), NameList(13), NameList(14), fOSUserName)
Else
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), _
NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), _
NameList(10), NameList(11), NameList(12), NameList(13), NameList(14), _
NameList(15), fOSUserName)
End If
.SaveMessageOnSend = True ' save in Sent folder
.Send (False)
End With
ActiveWorkbook.Close
End Sub

Function fOSUserName() As String
' Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If lngX <> 0 Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = ""
End If
End Function
-----------------------

Bye,
Jay

[brettvba]

Good for sending attachments Jays post is better for sending to multi ppl .


'Need to set reference to Lotus Notes as well , Tools References
Private Sub SendNotesMail()
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 EmbedObj2 As Object
Dim EmbedObj4 As Object
Dim EmbedObj5 As Object
Dim EmbedObj6 As Object
Dim EmbedObj7 As Object
Dim EmbedObj8 As Object
Dim EmbedObj9 As Object
Dim EmbedObj10 As Object
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
Else
Maildb.OPENMAIL
End If
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
Recipient = mailname 'Range("a15").Value
MailDoc.sendto = Recipient
ccRecipient = Range("a16").Value
MailDoc.CopyTo = ccRecipient
bccRecipient = Range("a17").Value
MailDoc.BlindCopyTo = bccRecipient
Subject = "Your Text"
MailDoc.Subject = Subject
BodyText = "Your Text in "
MailDoc.Body = BodyText
MailDoc.SAVEMESSAGEONSEND = SaveIt
' Attachments and Range they have to be in
Attachment1 = Range("d15")
If Attachment1 <> "" Then
On Error Resume Next
Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment")
On Error Resume Next
Set EmbedObj1 = AttachME.EMBEDOBJECT(1454, "", Attachment1, "Attachment")
On Error Resume Next
MailDoc.CREATERICHTEXTITEM ("Attachment")
On Error Resume Next
End If

MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
MailDoc.SEND 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
Set EmbedObj2 = Nothing
Set EmbedObj3 = Nothing
Set EmbedObj4 = Nothing
Set EmbedObj5 = Nothing
Set EmbedObj6 = Nothing
Set EmbedObj7 = Nothing
Set EmbedObj8 = Nothing
Set EmbedObj9 = Nothing
Set EmbedObj10 = Nothing
Exit Sub
errorhandler1:
On Error Resume Next

Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
Set EmbedObj2 = Nothing
Set EmbedObj3 = Nothing
Set EmbedObj4 = Nothing
Set EmbedObj5 = Nothing
Set EmbedObj6 = Nothing
Set EmbedObj7 = Nothing
Set EmbedObj8 = Nothing
Set EmbedObj9 = Nothing
Set EmbedObj10 = Nothing
End Sub