Macro to Send Multiple Emails with Attachment through Lotus Notes

Good Morning All,

I am currently working on a macro to create an email through Lotus Notes based cell values on my worksheet, which also includes an attachment that is located on my desktop. I have attached the code that I have been working on that does work, but intermittently causes an error that tells me "Lotus Notes/ Domino has stopped working". I cant seem to find out what is causing the issue because sometimes the code works and sends the email and attachment and the next time I try it the error pops up....Any input would be greatly appreciated! I am running Notes 9 on Windows 7 Pro with Service Pack 1.

Code:

---

Sub LotusEmail()


Dim UserName As String
Dim MailDbName As String
Dim recipient As Variant
Dim Attachment1 As String
Dim Maildb As Object
Dim MailDoc As Object
Dim attachME As Object
Dim Session As Object
Dim EmbedObj1


With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
   
sn = Sheets("Email").Range("D2:D15")
 
    For j = 1 To UBound(sn)
    With Sheets("Email")
      .Range("A2").Value = sn(j, 1)
    End With
' Open and locate current LOTUS NOTES User


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


' Create New Mail and Address Title Handlers


Set MailDoc = Maildb.CreateDocument


MailDoc.Form = "Memo"


' Select range of e-mail addresses
recipient = Sheets("Email").Range("A8").Value
MailDoc.SendTo = recipient
ccRecipient = Sheets("Email").Range("A11").Value
MailDoc.copyto = ccRecipient
MailDoc.subject = "2015 Compensation Statements"
MailDoc.body = _
Sheets("Email").Range("A17").Value


MailDoc.SaveMessageOnSend = True


' Select E-Mail Attachment
Attachment1 = Sheets("Email").Range("A14").Value


If Attachment1 <> "" Then
On Error Resume Next
Set attachME = MailDoc.CreateRichTextItem("Attachment1")
Set EmbedObj1 = attachME.EmbedObject(1454, "Attachment1", Sheets("Email").Range("A14").Value, "")
On Error Resume Next
End If


MailDoc.PostedDate = Now()
On Error Resume Next
MailDoc.Send 0, recipient


Set Maildb = Nothing
Set MailDoc = Nothing
Set attachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing


errorhandler1:


Set Maildb = Nothing
Set MailDoc = Nothing
Set attachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing


With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With


    Next j
End Sub

---