Code for email via Lotus Notes

A quick module to send an email via Lotus Notes from Excel

Option Explicit
Sub BasicEmailSend()
'----------------------------------------------------------------------------
'Users MUST have their Lotus Notes open and running user information is taken from the logon for security purposes
'----------------------------------------------------------------------------
    On Error GoTo notesIsNotRunning
    AppActivate ("Notes")       'tries to active notes
    AppActivate "Microsoft Excel"
    GoTo LotusOk

notesIsNotRunning:        ' If lotus is not working then give an error message
    Dim notesErr, notesBox

LotusOk:
    On Error GoTo 0
    '----------------------------------------------------------------------------
    'Create email settings
    '----------------------------------------------------------------------------
    Dim session, Maildb, MailDoc, attachME1, EmbedObj1 As Object
    Dim name_string, Username, MyMailText, MailText, MailDbName As String
    Dim myAttachement, EmailAddress1, EmailAddress2, EmailAddress3, Recipient, ccRecipient, cuser As String
    Dim continue As Variant

    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 Not Maildb.IsOpen Then Maildb.OpenMail
    Set MailDoc = Maildb.CREATEDOCUMENT

    EmailAddress1 = Sheets("Sheet1").Range("B1")
    EmailAddress2 = Sheets("Sheet1").Range("B2")
    EmailAddress3 = Sheets("Sheet1").Range("B3")

    Recipient = Array(EmailAddress1, EmailAddress2)
    ccRecipient = Array(EmailAddress3)

    '----------------------------------------------------------------------------
    'Set the email type, optional body text and subject etc...
    '----------------------------------------------------------------------------
    MyMailText = InputBox("Please enter text to send with email?" & vbCrLf & vbCrLf & "Click OK to send without comment")
    Select Case MyMailText
    Case ""
        MailText = "This is a comment that is hard coded and is changed via VBA"
    Case Else
        MailText = MyMailText
    End Select

    With MailDoc
        .Form = "Memo"
        .ReturnReceipt = "1"
        .Subject = "This is a test of the excel to Lotus code"
        MailDoc.Sendto = Recipient
        MailDoc.CopyTo = ccRecipient
        .body = Replace(MailText, "@", vbCrLf)
        .postdate = Date
        .SaveMessageOnSend = True
    End With

    '----------------------------------------------------------------------------
    'Set the directory and file path for the attachment
    'This example will save this file to the c drive and email
    '----------------------------------------------------------------------------
    ChDir "C:\"
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:="C:\Test.xls"
    myAttachement = "C:\Test.xls"
    Application.DisplayAlerts = True

    '----------------------------------------------------------------------------
    'Putting the email together and sending
    '----------------------------------------------------------------------------
    Dim charcount As Long
    Dim FirstChar, LastChar As String

    Set attachME1 = MailDoc.CREATERICHTEXTITEM("myAttachement")
    Set EmbedObj1 = attachME1.EmbedObject(1454, "", myAttachement)
    MailDoc.PostedDate = Now
    Call MailDoc.send(False)

    Set session = CreateObject("Notes.NotesSession")
    name_string = session.Username
    For charcount = 1 To Len(name_string)
        If Mid(name_string, charcount, 1) = "=" Then FirstChar = charcount + 1
        If Mid(name_string, charcount, 1) = "/" Then
            LastChar = charcount - 1
            charcount = Len(name_string) + 1
        End If
    Next
    Username = Mid(name_string, FirstChar, LastChar - FirstChar + 1)
    cuser = Split(Username, " ")(0)
    continue = MsgBox("Message sent successfully.", vbOKOnly, "Thank You - " & cuser)

    '----------------------------------------------------------------------------
    'Optional delete uploaded file users system and hides sheets
    '----------------------------------------------------------------------------
    'Kill myAttachement
    End

End Sub