Here are 2 function to create email from Ms Access using
Lotus Notes...You will have to change it a bit for use. I
have attached file names in tables for attachments that I
must send out all the time. Also, I only coded to allow
for 15 attachment but it can be changed.
Option Compare Database
Option Explicit
'Function used to determine if Lotus Notes is open before
trying to send any Lotus Notes
Declare Function FindWindowByClass Lib "User32"
Alias "FindWindowA" (ByVal lpClassName As String, ByVal
lpWindowName As Long) As Long
Function SendNotesMail(strNames As String, strBodyMsg As
String, strSubject As String, Optional strFile1 As String,
Optional strFile2 As String, Optional strFile3 As String, _
Optional strFile4
As String, Optional strFile5 As String, Optional strFile6
As String, Optional strFile7 As String, Optional strFile8
As String, Optional strFile9 As String, _
Optional strFile10
As String, Optional strFile11 As String, Optional
strFile12 As String, Optional strFile13 As String,
Optional strFile14 As String, Optional strFile15 As
String, Optional strFile As String) As Boolean
On Error GoTo Proc_Err
'SendNotesMail("(e-mail address removed)","This is a
test","Eat this","","","",0)
Dim GetNotes As
Object
'Call Lotus Notes
Dim MailDb As
Object
'Lotus Notes
Mail Database
Dim strMailServer As
String
'User's Mailbox Server
Dim strMailFile As
String
'User's Mailbox Path
Dim CreateMail As
Object
'Create Notes Memo
Dim AttachFile As Object, AttachFile2 As Object,
AttachFile3 As Object, AttachFile4 As
Object 'Memo File
Attachment
Dim AttachFile5 As Object, AttachFile6 As Object,
AttachFile7 As Object, AttachFile8 As
Object 'Memo File Attachment
Dim AttachFile9 As Object, AttachFile10 As Object,
AttachFile11 As Object, AttachFile12 As
Object 'Memo File Attachment
Dim AttachFile13 As Object, AttachFile14 As Object,
AttachFile15 As
Object
'Memo File Attachment
Dim intEmbed_Attachment As Integer,
intEmbed_Attachment2 As Integer, intEmbed_Attachment3 As
Integer 'Lotus Notes Constant for Attachments
Dim intEmbed_Attachment4 As Integer,
intEmbed_Attachment5 As Integer, intEmbed_Attachment6 As
Integer 'Lotus Notes Constant for Attachments
Dim intEmbed_Attachment7 As Integer,
intEmbed_Attachment8 As Integer, intEmbed_Attachment9 As
Integer 'Lotus Notes Constant for Attachments
Dim intEmbed_Attachment10 As Integer,
intEmbed_Attachment11 As Integer, intEmbed_Attachment12 As
Integer 'Lotus Notes Constant for Attachments
Dim intEmbed_Attachment13 As Integer,
intEmbed_Attachment14 As Integer, intEmbed_Attachment15 As
Integer 'Lotus Notes Constant for Attachments
Dim vntResponse As
Variant
'Msgbox presented in case
Lotus Notes is unopen
Dim FoundNotes As Long, InNames As String, Counter As
Integer
CheckforLotusNotes:
FoundNotes = FindWindowByClass("NOTES",
0&) 'Checks to see if Lotus Notes is Open
'If not open, then ask user to open their Lotus
Notes.
If FoundNotes = 0 Then
vntResponse = MsgBox("This program cannot run
without Lotus Notes. Please do the following and press
OK." _
& Chr(13) & Chr(13) & Chr(10)
& "1. Open your Lotus Notes, then" & Chr(10) _
& "2. Open your Mail or any
other database (insert password when requested)" _
& Chr(13) & Chr(13) & Chr(10)
& "Please email the " & strFile1 & " to " & strNames
& ".", 1, _
Chr(13) & Chr(13) & Chr(10)
& "CANNOT FIND LOTUS NOTES")
If vntResponse = vbOK
Then 'Checks response
GoTo CheckforLotusNotes
Else
MsgBox "Email was not sent." & Chr$(13) &
Chr$(10) & "Please notify Systems", , "OPERATION CANCELLED"
Exit Function
End If
End If
Set GetNotes = CreateObject
("Notes.NotesSession") 'Call Lotus Notes.
Lotus Notes must be open.
DoEvents
'Wait for Processor to Create Object
'Pulls the user's Mailbox Server and FileName from the
NOTES.INI file
Let strMailServer = GetNotes.GETENVIRONMENTSTRING
("MailServer", True)
Let strMailFile = GetNotes.GETENVIRONMENTSTRING
("MailFile", True)
'Opens the Mail Database using the User's Parameters
Set MailDb = GetNotes.GETDATABASE(strMailServer,
strMailFile)
'creates the new document
Set CreateMail = MailDb.CREATEDOCUMENT
Const Embed_Attachment = 1454
Set AttachFile = CreateMail.CREATERICHTEXTITEM("Body")
If strFile = "" Then
'No attachment - no action required
Else
'creates a rich text item in the body of the memo
this is needed to embed an object in the memo
' Set AttachFile = CreateMail.CREATERICHTEXTITEM
("Body")
'Embeds an attachment into the memo, the 3rd
arguement is the file and pathname
'the number 1454 is a Lotus Notes constant meaning
Embed_Attachment
'Const Embed_Attachment = 1454 'Lotus Notes
constant value for Embed_Attachment
Dim Attachment As Object
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile, "")
End If
If strFile1 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile1, "")
End If
If strFile2 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile2, "")
End If
If strFile3 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile3, "")
End If
If strFile4 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile4, "")
End If
If strFile5 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile5, "")
End If
If strFile6 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile6, "")
End If
If strFile7 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile7, "")
End If
If strFile8 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile8, "")
End If
If strFile9 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile9, "")
End If
If strFile10 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile10, "")
End If
If strFile11 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile11, "")
End If
If strFile12 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile12, "")
End If
If strFile13 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile13, "")
End If
If strFile14 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile14, "")
End If
If strFile15 = "" Then
'No attachment - no action required
Else
Set Attachment = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", strFile15, "")
End If
'Send Viewer
'
' If sendViewer Then
' Dim Attachment3 As Object
' 'Set Attachment3 = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", "C:\Mydocu~1
\Reports\Snpvw80.exe", "")
' Set Attachment3 = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", "C:\DATAB\Snpvw80.exe", "")
' 'Set Attachment3 = AttachFile.EMBEDOBJECT
(Embed_Attachment, "", "\\nc-urp2-hepdc01
\software\pcraccess\snpvw80.exe", "")
' End If
'
'Set up Array for People to Send Note
'Add extra comma to the end of the names string,
otherwise last name not included!
InNames = strNames & ","
Counter = 1
'Dim aName(9) As String
Dim aName(50) As String
Do Until InStr(1, InNames, ",") = 0
Let aName(Counter) = Mid(InNames, 1, InStr(1,
InNames, ",") - 1)
InNames = Mid(InNames, InStr(1, InNames, ",") + 1)
Counter = Counter + 1
Loop
'debug & test only
'=============================
' strSubject = strSubject & " - TEST ONLY - Please
Delete"
DoEvents
'=============================
'the various items in the memo are assigned
With CreateMail
.Form = "Memo"
.SendTo = aName
.Subject = CStr(Trim(strSubject))
.Body = CStr(Trim(strBodyMsg))
.Send (False)
End With
strBodyMsg =
Empty 'Clear the
message
SendNotesMail = True
Proc_Exit:
Exit Function
Proc_Err:
SendNotesMail = False
If Err.Number = 7225 Then
Resume Next
Else
MsgBox Err.Number & " " & Err.Description
GoTo Proc_Exit
End If
End Function
Public Function SendMail(SendMailID As String)
'added 05242004 KTT
Dim bAns As Byte
bAns = MsgBox("Send out " & SendMailID & " automated
email?", vbYesNo, "Lotus Notes")
If bAns = vbNo Then Exit Function
Dim strSource, strDest As String
Dim strNames As String
Dim strBodyMsg As String
Dim strSubject As String
Dim strFile As String, strFile1 As String, strFile2 As
String, strFile3 As String, strFile4 As String, strFile5
As String
Dim strFile6 As String, strFile7 As String, strFile8
As String, strFile9 As String, strFile10 As String
Dim strFile11 As String, strFile12 As String,
strFile13 As String, strFile14 As String, strFile15 As
String
Dim strCompany As String
Dim sPath As String
Dim db As Database
Dim rs As Recordset
Dim SQL As String
Dim x As Integer
Dim count As Long
Dim clsRp As New clsReportPrint
Set db = CurrentDb
SQL = "SELECT ML.SendMailID, ML.Address, ML.Body,
ML.Subject, MF.File " & _
"FROM tblMailList AS ML LEFT JOIN tblMailFiles
AS MF ON ML.SendMailID = MF.SendMailID " & _
"WHERE ML.SendMailID = '" & SendMailID & "'"
'Debug.Print SQL
Set db = CurrentDb
Set rs = db.OpenRecordset(SQL, dbOpenSnapshot)
rs.MoveFirst
strNames = rs.fields("Address")
strBodyMsg = Nz(rs.fields("Body"))
strSubject = Nz(rs.fields("Subject"))
x = 0
Do Until rs.EOF
'check for file existence of the PDF File in
C:\rptcache if not found
'check for file existence using GetPDFDir()
If Len(Dir(clsRp.LocalPrintFolder & "\" & rs.fields
("File"))) > 0 Then
sPath = clsRp.LocalPrintFolder & "\"
Else
If InStr(1,
Application.CurrentDb.NAME, "CPMIWeekly") <> 0 Then
sPath = GetPDFDir(True)
Else
sPath = GetPDFDir()
End If
End If
Set clsRp = Nothing
x = x + 1
If Len(Trim(rs.fields("File"))) = 0 Or IsNull
(rs.fields("File")) Then
strFile = ""
Else
strFile = "strFile" & x
End If
If strFile = "strFile1" Then
strFile1 = sPath & rs.fields("File")
End If
If strFile = "strFile2" Then
strFile2 = sPath & rs.fields("File")
End If
If strFile = "strFile3" Then
strFile3 = sPath & rs.fields("File")
End If
If strFile = "strFile4" Then
strFile4 = sPath & rs.fields("File")
End If
If strFile = "strFile5" Then
strFile5 = sPath & rs.fields("File")
End If
If strFile = "strFile6" Then
strFile6 = sPath & rs.fields("File")
End If
If strFile = "strFile7" Then
strFile7 = sPath & rs.fields("File")
End If
If strFile = "strFile8" Then
strFile9 = sPath & rs.fields("File")
End If
If strFile = "strFile9" Then
strFile9 = sPath & rs.fields("File")
End If
If strFile = "strFile10" Then
strFile10 = sPath & rs.fields("File")
End If
If strFile = "strFile11" Then
strFile11 = sPath & rs.fields("File")
End If
If strFile = "strFile12" Then
strFile12 = sPath & rs.fields("File")
End If
If strFile = "strFile13" Then
strFile13 = sPath & rs.fields("File")
End If
If strFile = "strFile14" Then
strFile14 = sPath & rs.fields("File")
End If
If strFile = "strFile15" Then
strFile15 = sPath & rs.fields("File")
End If
rs.MoveNext
Loop
Set clsRp = Nothing
SendNotesMail strNames, strBodyMsg, strSubject,
strFile1, strFile2, strFile3, strFile4, strFile5,
strFile6, strFile7, strFile8, strFile9, strFile10,
strFile11, strFile12, strFile13, strFile14, strFile15
End Function
