Public Function SendAMsg(UID As Long, OLSbj As String, OLTo As String, _
OLCC As String, OLBdy As String, bEnc As Boolean, lImprt As Long) As Long
' Send a message for which the recipients, subject line, and message body have been prepared
' Because this is Access-resident, it does not silently send through Outlook.
' ON ENTRY:
' OLSbj = subject line
' OLTo = to-recipients
' OLCC = cc-recipients
' OLBdy = body of message
' bEnc = Yes/No - digitally sign and encrypt the message
' lImprt = olImportanceHigh, olImportanceNormal, olImportanceLow
' UID = internal PK of user table corresponding to sender of message, needed because
' when we finish, we will audit-log the event.
' ON RETURN:
' Function value is a code showing what happened
' 0 = all is well, message was sent, no problems
' 1 = error, any sanity check failed. usually means a missing parameter.
' 2 = error, trap tripped
Dim OLApp As Outlook.Application 'ACCESS construct to allow us to bit-twiddle Outlook
Dim OLMsg As Outlook.MailItem 'a mail message within Outlook
Dim OLNS As Outlook.NameSpace 'need this to get to the MAPI name space
Dim OLFld As Outlook.MAPIFolder 'need this for sending mail
Dim OLIns As Outlook.Inspector 'need this to set encryption
Dim OLBar As Office.CommandBar 'make this a command-bar object
Dim OLEnc As Office.CommandBarButton 'a reference to a specific button
Dim OLSgn As Office.CommandBarButton 'a reference to another specific button
Dim TrapPoint As String
Dim TrapError As String 'working strings
Dim EvtMsg As String
Dim lRetSts As Long 'status code we will return
Dim OLNew As Boolean 'flag for case of new instance of Outlook
' sanity checks - we need to know who is sending the message. we need to know the message body.
' we need a subject line. we need a list of to-recipients. we do not care about the CC list.
If UID = 0 Then
lRetSts = 1 'sanity check - no user identification
GoTo SAM_Finished 'skip the rest of this clap-trap
End If
If OLTo = "" Then
lRetSts = 1 'sanity check - no TO list
GoTo SAM_Finished 'skip the rest of this clap-trap
End If
If OLBdy = "" Then
lRetSts = 1 'sanity check - no message body
GoTo SAM_Finished 'skip the rest of this clap-trap
End If
If OLSbj = "" Then
lRetSts = 1 'sanity check - no subject lline
GoTo SAM_Finished 'skip the rest of this clap-trap
End If
' Next, let us look into the outlook application. Outlook does not like to have two instances in
' memory at one time, so check for an existing instance first.
Set OLApp = Nothing 'start with simplest assumption
On Error Resume Next 'block traps while we poke around
Set OLApp = GetObject(, "Outlook.Application") 'find existing instance of Outlook
On Error GoTo 0 'remove the trap block
On Error GoTo SAM_Trapped 'ok, we are good now, restore intended trap.
TrapPoint = "Create New Outlook Application"
lRetSts = 0 'assume we are going to work
' at this point, either we got an application link or we did not
OLNew = False 'assume we found one
If OLApp Is Nothing Then 'did we find an existing Outlook we could use?
OLNew = True 'no, have to create one, so ...
Set OLApp = CreateObject("Outlook.Application") 'create a private apps object
End If
' we have an application. use it to connect to an MAPI session so we can send something
TrapPoint = "Login to MAPI namespace"
Set OLNS = OLApp.GetNamespace("MAPI") 'get into the namespace
OLNS.Logon , , False, False 'we created or tested the app already
' point to the MAPI Outbox (folder)
TrapPoint = "Select and work in Outbox"
Set OLFld = OLNS.GetDefaultFolder(olFolderOutbox) 'find the outbox folder
' create a new message in the Outbox folder
TrapPoint = "Create message and define properties"
Set OLMsg = OLFld.Items.Add(olMailItem) 'from which we will send a single mail message
' populate that puppy
OLMsg.Importance = lImprt 'start populating the mail message
OLMsg.To = OLTo 'fill in first set of recipients
OLMsg.cC = OLCC 'fill in second set of recipients
'no BCC recipients at this time
OLMsg.Subject = OLSbj 'fill in the message subject
OLMsg.Body = OLBdy 'fill in the message body
OLMsg.BodyFormat = olFormatPlain 'make it totally plaintext
Set OLIns = OLMsg.GetInspector 'get the inspector so we can open the toolbars
OLIns.Activate 'ok, now that we have it, let us actually use it
' now, if we NEED to do this, let us try to set the ENCRYPT flag. Site rules say if we
' are going to encrypt it, we must also digitally sign it.
If bEnc = True Then 'see if we even need to bother
Set OLBar = OLIns.CommandBars("Standard") 'get to the standard toolbar
Set OLEnc = OLBar.FindControl(, EncryptMsgCtrl) 'which has ENCRYPT and SIGNDIGITAL
Set OLSgn = OLBar.FindControl(, DigitalSigCtrl)
If Not OLSgn Is Nothing Then 'if we found it, ...
If OLSgn.Enabled = True Then 'and if it is enabled, ...
If OLSgn.State = msoButtonUp Then 'and if it is not already set, ...
OLSgn.Execute
End If
End If
End If
If Not OLEnc Is Nothing Then 'if we found it, ...
If OLEnc.Enabled = True Then 'and if it is enabled, ...
If OLEnc.State = msoButtonUp Then 'and if it is not already set, ...
OLEnc.Execute 'make it encrypted.
End If
End If
End If
End If 'end - if we are going to encrypt the message
' message exists. if encryption was required, that has been set.
TrapPoint = "Send message on its way"
OLMsg.Send 'send it on its way, Nellie Forbush
' start cleaning up after us
EvtMsg = "Sent mail (subject = " & OLSbj & ")"
If bEnc Then EvtMsg = EvtMsg & " (Encryption requested)"
AuditEvent evtSentMail, UID, EvtMsg
GoTo SAM_Finished
SAM_Trapped:
If Err.Number = 287 Then
AuditEvent evtErrTrap, UID, "Error 287 just after trap point " & TrapPoint
Resume Next
End If
TrapError = "Trap: Error number is " & CStr(Err.Number) & vbCrLf
TrapError = TrapError & Err.Description & vbCrLf
TrapError = TrapError & "In SendAMsg\" & TrapPoint & vbCrLf
MsgBox TrapError, vbOKOnly, "Trap Detected" 'note the error as a message box
AuditEvent evtErrTrap, UID, TrapError 'make a record of it
lRetSts = 2 'return trap status
Resume SAM_Finished 'fall into final cleanup code
SAM_Finished:
On Error Resume Next 'disallow traps
Set OLSgn = Nothing 'release these objects
Set OLEnc = Nothing
Set OLBar = Nothing
Set OLMsg = Nothing 'release the link to the message
Set OLFld = Nothing 'dereference the folder
If Not OLNS Is Nothing Then
OLNS.Logoff 'done with this session
End If
Set OLNS = Nothing 'dereference this puppy
If OLNew Then
OLApp.Quit 'release the application
End If
Set OLApp = Nothing 'done with the application
SendAMsg = lRetSts 'return a status code
On Error GoTo 0 'revoke trap interceptor
End Function
