jjds1981
02-02-2015, 08:30 AM
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.
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
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.
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