Private Sub subHandleSendingEmail(sDisplayOrSend As String, _
sTo As String, _
sCC As String, _
sBCC As String, _
sSubject As String, _
sMsgBody As String, _
sAtts As String)
'sAtts is expected to be a list of files to attach, delimited by "|" (known as a pipe)
'I've put the delimiter in a constant called sDLM
Const olFolderOutbox = 4
Const olFolderDrafts = 16
'This section of code will attempt to get an instance of the Outlook object using late binding.
'If Outlook is closed the code should open Outlook.
'If Outlook is not installed or the install is corrupted, this section of code should detect that.
On Error Resume Next
Dim oOutlookApp As Object
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Err.Clear
Set oOutlookApp = CreateObject("Outlook.Application")
If Err.Number <> 0 Then
Audit "mdlEmail", "fHandleSendingEmail", "", "Problem creating an Outlook object. Error: " & Err.Number & " " & Err.Description
MsgBox "Error: " & Err.Number & vbCrLf & vbCrLf & _
Err.Description & vbCrLf & vbCrLf & _
"Apparently you do not have Outlook installed or configured properly.", vbOKOnly + vbInformation, "Um..."
Err.Clear
Set oOutlookApp = Nothing
Exit Sub
End If
End If
On Error GoTo 0
Dim oSession As Object, oMsg As Object, oAttach As Object
Dim i As Integer, sEntryID As String
On Error Resume Next
Set oSession = CreateObject("Redemption.RDOSession")
If Err.Number <> 0 Then
MsgBox "Please contact your database administrator and give him the following message:" & vbCrLf & vbCrLf & _
"There was a problem creating the RDOSession. Apparently Outlook Redemption Objects is not installed.", vbOKOnly + vbInformation, "Um..."
Err.Clear
Set oSession = Nothing
Set oOutlookApp = Nothing
Exit Sub
End If
On Error GoTo 0
oSession.Logon
Set oMsg = oSession.GetDefaultFolder(olFolderDrafts).Items.Add
sEntryID = oMsg.EntryID
'Multiple email addresses can be passed into the email address fields
'by passing them into this function, separated by a semicolon
'If you want to validate the email addresses to make sure they actually have an
'@ symbol in them and have a domain name that's formatted correctly, you'll
'need to do it before passing it into this function or do it below.
oMsg.To = sTo
oMsg.CC = sCC
oMsg.Bcc = sBCC
oMsg.Subject = sSubject
'This code will put the attachment filenames listed in sAtts into an array
'and then attach each file as an attachment and embed the jpegs into the body.
If sAtts <> "" Then
i = 0
If InStr(sAtts, sDLM) = 0 Then sAtts = sAtts & sDLM & " "
'Remove any doubled up delimiters
sAtts = Replace(sAtts, sDLM & sDLM, sDLM)
Dim aryAtt() As String
aryAtt = Split(sAtts, sDLM)
Do Until i = (UBound(aryAtt) + 1)
'Check to see if the filename is blank before attaching it
If Trim(aryAtt(i)) <> "" Then
'Check to see if the file actually exists before attaching it
If Dir(aryAtt(i)) <> "" Then
Set oAttach = oMsg.Attachments.Add(aryAtt(i))
'If the attachment is a .jpg assume that we want to embed it in the email
If right(aryAtt(i), 4) = ".jpg" Then
oAttach.Fields("MimeTag") = "image/jpeg"
oAttach.Fields(&H3712001E) = "picture" & CStr(i)
'I'm assuming we want the pictures below the optional text that's passed into this function
sMsgBody = sMsgBody & "<br><br><IMG align=baseline border=0 hspace=0 src=cid:picture" & CStr(i) & "><br>"
End If
End If
End If
i = i + 1
Loop
End If
oMsg.HTMLBody = sMsgBody
oMsg.Save
If LCase(sDisplayOrSend) = "send" Then
oMsg.Send
End If
oSession.Logoff
Set oAttach = Nothing
Set oMsg = Nothing
Set oSession = Nothing
If LCase(sDisplayOrSend) = "display" Then
Set oMsg = oOutlookApp.GetNamespace("MAPI").GetItemFromID(sEntryID)
oMsg.Display
Set oMsg = Nothing
End If
Set oOutlookApp = Nothing
End Sub
