Option Compare Database
Option Explicit
Private appOutlook As Outlook.Application
'SendEM Sends an email
'For each address, any text found in <> will be treated as an SMTP address.
'An attempt is first made to refer to an object with a matching name.
'If this succeeds, but the address is ambiguous, the SMTP address will be used
' to resolve it.
'If no matching item is found then it will create a simple SMTP: entry
' of the following format : "Display Name<SMTP Address>".
Public Function SendEM(Optional ByVal strTo As String, _
Optional ByVal strCC As String, _
Optional ByVal strBCC As String, _
Optional ByVal strSubject As String, _
Optional ByVal strBody As String, _
Optional ByVal strAttachments As String) As Boolean
Dim blnOpen As Boolean
Dim strItem As String
Dim miMail As MailItem
SendEM = False
blnOpen = Not (appOutlook Is Nothing)
If Not blnOpen Then
On Error Resume Next
Set appOutlook = GetObject(Class:="Outlook.Application")
On Error GoTo 0
blnOpen = Not (appOutlook Is Nothing)
If Not blnOpen Then _
Set appOutlook = CreateObject(Class:="Outlook.Application")
End If
With appOutlook
Set miMail = .CreateItem(ItemType:=olMailItem)
With miMail
Call .Display
Call AddRecipient(miMail, strTo, olTo)
Call AddRecipient(miMail, strCC, olCC)
Call AddRecipient(miMail, strBCC, olBCC)
.Subject = strSubject
.Body = strBody & .Body
Call .Send
End With
If Not blnOpen Then Set appOutlook = Nothing
End With
End Function
Private Function AddRecipient(ByRef miMail As MailItem, _
strList As String, _
lngType As Long) As Boolean
Dim varItem As Variant
With miMail.Recipients
For Each varItem In Split(strList, ";")
With .Add(varItem)
.Type = lngType
AddRecipient = Not .Resolve
If AddRecipient Then Exit Function
End With
Next varItem
End With
End Function
'Some sample code from Microsoft
' function to attempt ambiguous name resolution (ANR)
Private Function TryANR(objRecip As Recipient) As Boolean
Dim objAmbigEntries As AddressEntries ' possible resolutions
Dim strChosenID As String ' ID of address entry chosen by user
' ... set up error handling ...
Set objAmbigEntries = objRecip.AmbiguousNames
If objAmbigEntries Is Nothing Then
MsgBox "No eligible names for resolution"
objRecip.Delete ' nothing else can be done at this point
TryANR = False
Else
' show address entries to user so one can be chosen, and save its
' entry identifier: strChosenID = objAddrEntry.ID
objRecip.ID = strChosenID
TryANR = True
End If
End Function
Public Function SendItem(Optional ByVal strTo As String, _
Optional ByVal strCC As String, _
Optional ByVal strBCC As String, _
Optional ByVal strSubject As String, _
Optional ByVal strBody As String, _
Optional ByVal strAttachments As String) As Boolean
End Function
Comment