Bob,
I posted this in mid June - hope it helps
Sub Send_ETCMail()
Dim oSess As Object, msg As String
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
Dim direct As Object
Dim var As Variant
Dim flag As Boolean
On Error GoTo Error1
Set oSess = CreateObject("notes.notessession")
Set oDB = oSess.getdatabase("SERVER NAME HERE", "")
Call oDB.openmail
flag = True
With ThisWorkbook.Sheets("Send Parameters") 'I set up a
datalist in the workbook for this
AttachPath = .Range("AttachPath") 'You can do
this with text
AttachName = .Range("AttachName") '
To_Address = .Range("To_Address") '
To_Name = .Range("To_Name") '
InstrText = .Range("InstrText") '
End With
AttachFile = AttachPath & "/" & AttachName
msg0 = "AUTOMATED MESSAGE TEXT IF DESIRED"
If Not (oDB.IsOpen) Then flag = oDB.Open("", "")
If Not flag Then
MsgBox "Cant't open mail file: " & oDB.server & " " &
oDB.FilePath
GoTo Error1
End If
Set oDoc = oDB.createdocument
Set oItem = oDoc.createrichtextitem("BODY")
oDoc.Form = "Memo"
oDoc.Subject = "Estimate To Complete File for Review"
oItem.appendtext ("ETC File Attachment")
oItem.addnewline (2)
On Error GoTo err02
oItem.embedObject 1454, "", AttachFile, "mail.rtf"
S001:
If rtn01 = vbOK Then msg = NoAttach_msg & msg
oDoc.sendto = To_Address
oDoc.body = msg0
oDoc.postdate = Date
oDoc.SaveMessageOnSend = True
oDoc.Send False
Exit Sub
Error1:
On Error Resume Next
MsgBox "Error in Lotus Notes Email Script"
Set oItem = Nothing
Set oDoc = Nothing
Set oDB = Nothing
Set oSess = Nothing
Exit Sub
err02:
Err.Clear
msg1 = "Attachment: [" & AttachName & "]" & " Was Not
Found in" & vbCrLf & " Directory: [" & AttachPath & "]"
msg1 = msg1 & vbCrLf & vbCrLf
msg1 = msg1 & "Do you wish to send advisory email without
attachment?"
rtn01 = MsgBox(msg1, vbCritical + vbOKCancel, "PSR SendMail
Utility")
If rtn01 = vbOK Then Resume S001
msg2 = "SendMail Routine Aborted for Recipient:" & vbCrLf &
" [" & To_Address & "]"
rtn02 = MsgBox(msg2, vbOKOnly, "PSR SendMail Utility")
End Sub
