'send email
Set mySafeEmail = New clsSendEmail
Call mySafeEmail.EMAIL_SAFE(strEmailRecipient, strMessageType)
And the code for the class is:
Option Compare Database
Option Explicit
Dim WithEvents ObjOutlook As Outlook.Application, myNameSpace As Object
Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objOpenInspector As Outlook.Inspector
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents colSentItems As Items
Dim strAttachmentFullName As String
Dim sMailItem As Redemption.SafeMailItem
Public Sub Class_Initialize()
Set ObjOutlook = CreateObject("Outlook.Application", "localhost")
Set objInspectors = ObjOutlook.Inspectors
Set myNameSpace = ObjOutlook.GetNamespace("MAPI")
Set colSentItems = myNameSpace.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Class_Terminate()
Set objOpenInspector = Nothing
Set objInspectors = Nothing
Set objMailItem = Nothing
Set colSentItems = Nothing
End Sub
Public Sub EMAIL_SAFE(strEmailAddress As String, strMessageType As String)
On Error GoTo EMAIL_SAFE_ERROR
'we don't use redemption objects because we only add the recipient
'and open the new mailtiem
Dim objExplorer As Outlook.Explorer
Dim objOutbox As Outlook.MAPIFolder
'show Outlook if not open
If ObjOutlook.Explorers.Count = 0 Then
Set objOutbox = myNameSpace.GetDefaultFolder(olFolderOutbox)
objOutbox.Display
End If
'new Outlook message
Set objMailItem = ObjOutlook.CreateItem(olMailItem) 'Create a new message
If strMessageType = "HTML" Then
objMailItem.BodyFormat = olFormatHTML
Else
objMailItem.BodyFormat = olFormatPlain
End If
objMailItem.To = strEmailAddress
'show the message
objMailItem.Display
EMAIL_SAFE_EXIT:
Exit Sub
EMAIL_SAFE_ERROR:
MsgBox Err.Number & Err.Description
End Sub
Private Sub vcLOG_SENT_EMAIL(strEntryID As String)
'this sub logs the email details into the database table
'it looks for the last sent item and checks to see if the recipient and time matches
Dim rstLog As DAO.Recordset
Dim oMailItem As MailItem
Dim strCC As Variant, strbCC As String, strSender As String
Dim strTimeSent As String, strBody As String, strRecipient As String
Dim strSubject As String, strAttachment As String, iCount As Integer
Dim oSentItemsAdd As Object
On Error GoTo vcLOG_EMAIL_ERROR
Set oSentItemsAdd = myNameSpace.GetDefaultFolder(olFolderSentMail)
Set oMailItem = myNameSpace.GetItemFromID(strEntryID)
Set sMailItem = CreateObject("Redemption.SafeMailItem")
'use Redeption object as we'll need to access protected properties
sMailItem.Item = oMailItem
'read the required data
strCC = sMailItem.CC
strbCC = sMailItem.bCC
strRecipient = sMailItem.To
strSender = sMailItem.SenderEmailAddress
strSubject = sMailItem.SUBJECT
strBody = sMailItem.BODY
strTimeSent = sMailItem.SentOn
strAttachment = ""
For iCount = 1 To sMailItem.Attachments.Count
'only not embedded attachments
Dim strCID As String
strCID = sMailItem.Attachments.Item(iCount).Fields(&H3712001E)
If strCID = "" Then
strAttachment = strAttachment & ";" & sMailItem.Attachments.Item(iCount).Filename
End If
Next
If Len(strAttachment) > 1 Then strAttachment = Right(strAttachment, Len(strAttachment) - 1)
'we need to add a record to the log table
Set rstLog = CurrentDb.OpenRecordset("tblEmailLog", dbOpenDynaset)
rstLog.AddNew
rstLog("DATE_SENT") = Left(strTimeSent, InStr(strTimeSent, " "))
rstLog("TIME_SENT") = Right(strTimeSent, InStr(strTimeSent, " ") + 1)
rstLog("SEND_BY") = strSender
rstLog("SEND_TO") = strRecipient
rstLog("CC") = strCC
rstLog("bCC") = strbCC
rstLog("MESSAGE_ID") = strEntryID
rstLog("SUBJECT") = strSubject
rstLog("ATTACHMENT") = strAttachment
If Form_frmSendEmail.chkSave = True Then rstLog("BODY") = strBody
rstLog.Update
rstLog.Close
Set rstLog = Nothing
vcLOG_EMAIL_EXIT:
Exit Sub
vcLOG_EMAIL_ERROR:
MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub colSentItems_ItemAdd(ByVal Item As Object)
Dim strEntryID As String, sItem As Redemption.SafeMailItem
If Item.Class = olMail Then
Item.Save
strEntryID = Item.EntryID
vcLOG_SENT_EMAIL (strEntryID)
End If
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If Inspector.CurrentItem.Class = olMail Then
Set objMailItem = Inspector.CurrentItem
Set objOpenInspector = Inspector
End If
End Sub
Private Sub objMailItem_Send(Cancel As Boolean)
Dim sMAPI_Utils As MAPIUtils, i As Integer
Set sMAPI_Utils = CreateObject("Redemption.MAPIUtils")
sMAPI_Utils.DeliverNow
End Sub
Private Sub objOpenInspector_Close()
'lets check to see if the outbox has anything in it and wait if it does
Dim l As Long, colOutbox As Items
CHECK_OUTBOX:
Set colOutbox = myNameSpace.GetDefaultFolder(olFolderOutbox).Items
If colOutbox.Count > 0 Then
'open the custom dialog form
If Not IsLoaded("frmSTILL_SENDING") Then
DoCmd.OpenForm "frmSTILL_SENDING"
End If
For l = 1 To 5 ' Start loop.
DoEvents ' Yield to operating system.
Sleep (100)
Next l
If Form_frmSTILL_SENDING.lblCancel.Caption = "Cancel" Then
'means the user clicked the cancel button
MsgBox "THIS EMAIL HAS NOT BEEN LOGGED!", vbExclamation, "CANCELING"
If IsLoaded("frmSTILL_SENDING") Then DoCmd.Close acForm, "frmSTILL_SENDING"
Exit Sub
End If
'reneter the loop until the outbox is empty
GoTo CHECK_OUTBOX
Else
'add a small loop to allow item to be added to the sent folder
For l = 1 To 5
DoEvents
Next l
If IsLoaded("frmSTILL_SENDING") Then DoCmd.Close acForm, "frmSTILL_SENDING"
End If
End Sub
