Option Compare Database
Option Explicit
Public mobjDB As Object
Public Const Parters = 1
Public Const Approvers = 2
'this sub will: output a report as a file
'attach the file and add the predetermined subject and body
'email the designated person for that type of message
'delete the file that was output
'close the session with the server
Public Function SEND_EMAIL(ByVal ReportName As String, Subject As String, RecipientList As Integer, message As String) As Boolean
'open the session with the lotus notes server
SEND_EMAIL = True
If OPEN_SESSION Then
'output report to text file on C:\
' DoCmd.OutputTo acOutputReport, ReportName, acFormatRTF, "C:\tempreport.rtf", False
DoCmd.OutputTo acOutputReport, ReportName, acFormatTXT, "C:\tempreport.txt", False
' DoCmd.OutputTo acOutputReport, ReportName, acFormatXLS, "C:\tempreport.xls", False
' DoCmd.OutputTo acOutputReport, ReportName, acFormatHTML, "C:\tempreport.html", False
Dim EmailTo As String
'send mail to appropriate address
If RecipientList = Parters Then
EmailTo = Get_Email_for_Type("ReqPart")
Else
EmailTo = Get_Email_for_Type("ReqApp")
End If
If IsNull(EmailTo) Then
SEND_EMAIL = False
Else
SEND_EMAIL = EMAIL_REPORT(EmailTo, message, Subject, "C:\tempreport.txt")
' SEND_EMAIL = EMAIL_REPORT(EmailTo, message, Subject, "C:\tempreport.xls")
' SEND_EMAIL = EMAIL_REPORT(EmailTo, message, Subject, "C:\tempreport.html")
End If
'delete the file
Kill ("C:\tempreport.txt")
'call the close session sub to destroy the objects
CLOSE_SESSION
Else
SEND_EMAIL = False
End If
End Function
'unused, left for potential future use
Private Function SEND_MULTIPLE_EMAILS(strSendTo() As String, strBody As String, strSubject As String, Optional strFile As String) As Boolean
SEND_MULTIPLE_EMAILS = True
Dim SendOne As Variant
For Each SendOne In strSendTo
SEND_MULTIPLE_EMAILS = SEND_MULTIPLE_EMAILS And _
EMAIL_REPORT((SendOne), strBody, strSubject, strFile)
Next
End Function
Private Function Get_Email_for_Type(strType As String) As String
Get_Email_for_Type = DLookup("[Email]", "[NotifyEmails]", "[Type] = '" & strType & "' AND Active = -1")
End Function
Public Function OPEN_SESSION() As Boolean
Dim objSession As Object
Dim strServer As String
Dim strMailFile As String
'lotus notes must be open for module to work correctly
If MsgBox("Do you have Outlook running?", vbCritical + vbYesNo, "Warning!") = vbYes Then
'this code must be left out of the loop so that only one session is started
Set objSession = CreateObject("Notes.NOTESSESSION")
strServer = objSession.GETENVIRONMENTSTRING("mailserver", True)
strMailFile = objSession.GETENVIRONMENTSTRING("mailfile", True)
Set mobjDB = objSession.GETDATABASE(strServer, strMailFile)
OPEN_SESSION = True
Else
MsgBox "Please start Outlook and try again.", vbOKOnly, "Emails"
OPEN_SESSION = False
End If
End Function
Public Function EMAIL_REPORT(strSendTo As String, strBody As String, strSubject As String, Optional strFile As String) As Boolean
On Error GoTo EmailReport_Err
Dim objDoc As Object
Dim objRichTextAttach As Object
Dim objRichTextItem As Object
Dim objAttachment As Object
Const NOTES_RECIPIENTS = ""
Const NOTES_REPORTS_USER = ""
Const NOTES_MAIL_FILE = "C:\Email.txt"
Set objDoc = mobjDB.CREATEDOCUMENT
Set objRichTextAttach = objDoc.CREATERICHTEXTITEM("File")
Set objRichTextItem = objDoc.CREATERICHTEXTITEM(objDoc, "Body")
If strFile <> "" Then
Set objAttachment = objRichTextAttach.EMBEDOBJECT(1454, "", strFile)
End If
'set up the email to be sent
objRichTextItem.AppendText strBody
objDoc.REPLACEITEMVALUE "SendTo", strSendTo
objDoc.REPLACEITEMVALUE "Subject", strSubject
objDoc.SaveMessageOnSend = True 'send E-mail
objDoc.SEND False 'false for do not attach a form
EMAIL_REPORT = True
Exit_Here:
Set objAttachment = Nothing
Set objDoc = Nothing
Set objRichTextAttach = Nothing
Set objRichTextItem = Nothing
Exit Function
EmailReport_Err:
EMAIL_REPORT = False
Resume Exit_Here
End Function
Public Sub CLOSE_SESSION()
Set mobjDB = Nothing
End Sub
