Option Explicit On
Option Strict Off
Option Compare Binary
'=============================================================================================================
'
' cCDONTS Class Module
' --------------------
'
' Created By : Kevin Wilson
' http://www.TheVBZone.com ( The VB Zone )
' http://net.TheVBZone.com ( The VB Zone .net )
' http://rb.TheVBZone.com ( The VB Zone [RB] )
'
' Created On : April 26, 2002
' Last Update : May 11, 2005
'
' VB Versions : VB.NET 1.1 (VS.NET 2003)
'
' Requires : - SMTP (Simple Mail Transfer Protocol) installed on Microsoft Internet Information Server (IIS)
' version 4.0 or later... OR... Microsoft Exchange Server version 5.5 or better
' - CDONTS.DLL (Collaboration Data Objects for Windows NT Server) version 1.2 or better
' - The .NET Framework v1.1
'
' Description : This class module allows you to easily send Emails via the CDONT's object. The "SendEmail"
' method uses the parameters passed to it to send a simple Email (doesn't support attachments).
' The "SendEmailEx" and "SendEmailAdv" both use the properties of this class to send a more
' complex Emails (supports multiple attachments seperated by PIPE "|" ). All the "SendEmail*"
' methods support 1 FROM address, and multiple TO/CC/BCC addresses seperated by semi-colon ";".
'
' NOTE : If you are trying to use this class on an Exchange Server that doesn't have IIS installed on it,
' you MUST use the "SendMailAdv" method to send Emails because the "NewMail" object doesn't work
' with just Exchange Server installed
'
' See Also : http://msdn.microsoft.com/library/en-us/cdo/html/_denali_cdo_for_nts_library.asp?frame=true
' http://msdn.microsoft.com/library/en-us/cdo/html/_denali_cdo_for_nts_object_model.asp?frame=true
' http://msdn.microsoft.com/library/en-us/cdo/html/_denali_installing_cdo_for_nts.asp?frame=true
' http://www.4guysfromrolla.com/webtech/faq/Email/faq1.shtml
'
'-------------------------------------------------------------------------------------------------------------
' Example #1 :
'-------------------------------------------------------------------------------------------------------------
'
' Dim MAIL As cCDONTS
' Dim lngErrNum As Integer
' Dim strErrDesc As String
'
' Set MAIL = New cCDONTS
' MsgBox "CDO Version = " & MAIL.CdoVersion
' If MAIL.SendEmail("BillGates@Microsoft.com", _
' "Everyone@TheWorld.org", _
' "Everyone@TheGovernment.gov", _
' vbNullString, _
' "ButtHead@Microsoft.com", _
' "I'm Sorry", _
' "Sorry for all the crappy " & _
' "software, here's some money for all the time you wasted dealing with and debugging " & _
' "my software.", _
' True, CdoHigh, _
' lngErrNum, strErrDesc) = False Then
' MsgBox "Error!" & Chr(13) & Chr(13) & _
' "Error Number = " & CStr(lngErrNum) & Chr(13) & _
' "Error Description = " & strErrDesc, vbOKOnly + vbExclamation, " Error"
' Else
' MsgBox "Email Sent!"
' End If
' Set MAIL = Nothing
'
'-------------------------------------------------------------------------------------------------------------
' Example #2 :
'-------------------------------------------------------------------------------------------------------------
'
' Dim MAIL As cCDONTS
' Dim lngErrNum As Integer
' Dim strErrDesc As String
'
' Set MAIL = New cCDONTS
' MsgBox "CDO Version = " & MAIL.CdoVersion
' With MAIL
' .AddressFROM = "BillGates@Microsoft.com"
' .AddressTO = "Everyone@TheWorld.org"
' .AddressCC = "Everyone@TheGovernment.gov"
' .AddressReplyTo = "ButtHead@Microsoft.com"
' .Subject = "I'm Sorry"
' .Body = "Sorry for all the crappy software, here's some money for all the time you wasted " & _
' "dealing wiht and debugging my software."
' .BodyIsHTML = False
' .AttachFile = True
' .PriorityLevel = CdoLow
' .AttachmentEncoding = CdoEncodingBase64
' .AttachmentPath = "C:\BANK_INFO.DOC|C:\INSTRUCTIONS.DOC"
' End With
'
' If MAIL.SendEmailEx(lngErrNum, strErrDesc) = False Then
' MsgBox "Error!" & Chr(13) & Chr(13) & _
' "Error Number = " & CStr(lngErrNum) & Chr(13) & _
' "Error Description = " & strErrDesc, vbOKOnly + vbExclamation, " Error"
' Else
' MsgBox "Email Sent!"
' End If
' Set MAIL = Nothing
'
'=============================================================================================================
'
' Introduction to CDO for NTS
'
' The Microsoft® CDO for NTS Library (Collaboration Data Objects for Windows NT® Server) version 1.2.1 exposes
' messaging objects for use by Microsoft® Visual Basic®, C/C++, Microsoft® Visual C++®, and Visual Basic
' Scripting Edition (VBScript) applications. The library allows server applications to send and receive
' messages without requiring access to the Microsoft® Exchange Server. You can create programmable messaging
' objects, then use their properties and methods for sending and receiving.
'
' The CDO for NTS Library is intended to run on a Microsoft® Windows NT® Server, for example from Active Server
' Pages (ASP) script on a Microsoft® Internet Information Server (IIS). It is not intended to run on a client
' process, nor to access remote servers. No user dialog is invoked or supported by CDO for NTS.
'
' The CDO for NTS Library uses SMTP (Simple Mail Transfer Protocol) to interface with a Microsoft® Windows NT®
' Server. SMTP is an Internet standard for electronic mail among clients having common access to a server for
' message storage. The SMTP protocol is defined in RFC 821, and its message format is defined in RFC 822.
'
' The CDO for NTS Library interfaces with the SMTP (Simple Mail Transfer Protocol) server component of Microsoft®
' Internet Information Server (IIS) version 4.0 and later. The Session object uses the LogonSMTP method to
' differentiate the access from the Logon method of the the CDO Library, which interfaces with Microsoft®
' Exchange Server.
'
' The SMTP server component of IIS has its own message store mechanism. The Inbox and Outbox are mapped to
' directories in the file system, and no other folders exist. Message transfer takes place in such a way that
' spooling appears instantaneous, so the Inbox has no incoming queue and the Outbox is always empty.
'
' When CDO for NTS is running with IIS, the Inbox is a single common folder shared by all SMTP recipients and
' applications. It contains all messages received by IIS and destined for the local domains for which the SMTP
' server is configured. However, the incoming messages are segregated by the CDO for NTS Library according to
' their recipients. An application can only access messages destined for the address it used when it logged on.
'
' When CDO for NTS is running with the Microsoft Exchange Server, the Inbox is the regular Inbox of the messaging
' user's mailbox. When CDO for NTS is running with Microsoft MCIS 2.0 Mail, the Inbox is the messaging user's
' Post Office Protocol version 3 (POP3) server Inbox.
'
' Applications developed to run with CDO for NTS can also run with CDO for Exchange provided they do not use the
' NewMail object. Also, the Session object's LogonSMTP method should be changed to the CDO for Exchange
' session's Logon method.
'
'=============================================================================================================
'
' LEGAL:
'
' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit
' given where credit is due. Also, it is not required, but it would be appreciated if you would mention
' somewhere in your compiled program that that your program makes use of code written and distributed by
' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles.
'
' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server
' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products,
' utilities, or applications that directly compete with products, utilities, and applications created by Kevin
' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first
' obtaining the written consent of the author Kevin Wilson.
'
' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without
' warning or notice. Copyright© by Kevin Wilson. All rights reserved.
'
'=============================================================================================================
Imports System
Imports Microsoft
Imports Microsoft.VisualBasic
Imports CDONTS
Public Class cCDONTS
' CDO Error Constants
Private Const CdoE_CALL_FAILED As Int32 = &H80004005
Private Const CdoE_NOT_ENOUGH_MEMORY As Int32 = &H8007000E
Private Const CdoE_INVALID_PARAMETER As Int32 = &H80070057
Private Const CdoE_INTERFACE_NOT_SUPPORTED As Int32 = &H80004002
Private Const CdoE_NO_ACCESS As Int32 = &H80070005
Private Const CdoE_NO_SUPPORT As Int32 = &H80040102
Private Const CdoE_BAD_CHARWIDTH As Int32 = &H80040103
Private Const CdoE_STRING_TOO_Int32 As Int32 = &H80040105
Private Const CdoE_UNKNOWN_FLAGS As Int32 = &H80040106
Private Const CdoE_INVALID_ENTRYID As Int32 = &H80040107
Private Const CdoE_INVALID_OBJECT As Int32 = &H80040108
Private Const CdoE_OBJECT_CHANGED As Int32 = &H80040109
Private Const CdoE_OBJECT_DELETED As Int32 = &H8004010A
Private Const CdoE_BUSY As Int32 = &H8004010B
Private Const CdoE_NOT_ENOUGH_DISK As Int32 = &H8004010D
Private Const CdoE_NOT_ENOUGH_RESOURCES As Int32 = &H8004010E
Private Const CdoE_NOT_FOUND As Int32 = &H8004010F
Private Const CdoE_VERSION As Int32 = &H80040110
Private Const CdoE_LOGON_FAILED As Int32 = &H80040111
Private Const CdoE_SESSION_LIMIT As Int32 = &H80040112
Private Const CdoE_USER_CANCEL As Int32 = &H80040113
Private Const CdoE_UNABLE_TO_ABORT As Int32 = &H80040114
Private Const CdoE_NETWORK_ERROR As Int32 = &H80040115
Private Const CdoE_DISK_ERROR As Int32 = &H80040116
Private Const CdoE_TOO_COMPLEX As Int32 = &H80040117
Private Const CdoE_BAD_COLUMN As Int32 = &H80040118
Private Const CdoE_EXTENDED_ERROR As Int32 = &H80040119
Private Const CdoE_COMPUTED As Int32 = &H8004011A
Private Const CdoE_CORRUPT_DATA As Int32 = &H8004011B
Private Const CdoE_UNCONFIGURED As Int32 = &H8004011C
Private Const CdoE_FAILONEPROVIDER As Int32 = &H8004011D
Private Const CdoE_UNKNOWN_CPID As Int32 = &H8004011E
Private Const CdoE_UNKNOWN_LCID As Int32 = &H8004011F
Private Const CdoE_PASSWORD_CHANGE_REQUIRED As Int32 = &H80040120
Private Const CdoE_PASSWORD_EXPIRED As Int32 = &H80040121
Private Const CdoE_INVALID_WORKSTATION_ACCOUNT As Int32 = &H80040122
Private Const CdoE_INVALID_ACCESS_TIME As Int32 = &H80040123
Private Const CdoE_ACCOUNT_DISABLED As Int32 = &H80040124
Private Const CdoE_END_OF_SESSION As Int32 = &H80040200
Private Const CdoE_UNKNOWN_ENTRYID As Int32 = &H80040201
Private Const CdoE_MISSING_REQUIRED_COLUMN As Int32 = &H80040202
Private Const CdoE_BAD_VALUE As Int32 = &H80040301
Private Const CdoE_INVALID_TYPE As Int32 = &H80040302
Private Const CdoE_TYPE_NO_SUPPORT As Int32 = &H80040303
Private Const CdoE_UNEXPECTED_TYPE As Int32 = &H80040304
Private Const CdoE_TOO_BIG As Int32 = &H80040305
Private Const CdoE_DECLINE_COPY As Int32 = &H80040306
Private Const CdoE_UNEXPECTED_ID As Int32 = &H80040307
Private Const CdoE_UNABLE_TO_COMPLETE As Int32 = &H80040400
Private Const CdoE_TIMEOUT As Int32 = &H80040401
Private Const CdoE_TABLE_EMPTY As Int32 = &H80040402
Private Const CdoE_TABLE_TOO_BIG As Int32 = &H80040403
Private Const CdoE_INVALID_BOOKMARK As Int32 = &H80040405
Private Const CdoE_WAIT As Int32 = &H80040500
Private Const CdoE_CANCEL As Int32 = &H80040501
Private Const CdoE_NOT_ME As Int32 = &H80040502
Private Const CdoE_CORRUPT_STORE As Int32 = &H80040600
Private Const CdoE_NOT_IN_QUEUE As Int32 = &H80040601
Private Const CdoE_NO_SUPPRESS As Int32 = &H80040602
Private Const CdoE_COLLISION As Int32 = &H80040604
Private Const CdoE_NOT_INITIALIZED As Int32 = &H80040605
Private Const CdoE_NON_STANDARD As Int32 = &H80040606
Private Const CdoE_NO_RECIPIENTS As Int32 = &H80040607
Private Const CdoE_SUBMITTED As Int32 = &H80040608
Private Const CdoE_HAS_FOLDERS As Int32 = &H80040609
Private Const CdoE_HAS_MESSAGES As Int32 = &H8004060A
Private Const CdoE_FOLDER_CYCLE As Int32 = &H8004060B
Private Const CdoE_AMBIGUOUS_RECIP As Int32 = &H80040700
Private Const CdoW_NO_SERVICE As Int32 = &H40203
Private Const CdoW_ERRORS_RETURNED As Int32 = &H40380
Private Const CdoW_POSITION_CHANGED As Int32 = &H40481
Private Const CdoW_APPROX_COUNT As Int32 = &H40482
Private Const CdoW_CANCEL_MESSAGE As Int32 = &H40580
Private Const CdoW_PARTIAL_COMPLETION As Int32 = &H40680
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CLASS PROPERTY DECLARATIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
' Specifies who is sending the Email. This can not have multiple addresses.
' TIP: The following will send both your name and address "Kevin Wilson "
Public AddressFROM As String
' The address that the Email should be sent to when the recipient clicks the REPLY button on the Email.
' This can not have multiple addresses.
' TIP: The following will send both your name and address "Kevin Wilson "
Public AddressReplyTo As String
' Main recipient(s) of the Email. If using multiple addresses, seperate them with a semicolon (;)
' TIP: The following will send both your name and address "Kevin Wilson "
Public AddressTO As String
' Recipient(s) to "CARBON COPY" the Email to. If using multiple addresses, seperate them with a semicolon (;)
' TIP: The following will send both your name and address "Kevin Wilson "
Public AddressCC As String
' Recipient(s) to "BLIND CARBON COPY" the Email to. If using multiple addresses, seperate them with a semicolon (;)
' TIP: The following will send both your name and address "Kevin Wilson "
Public AddressBCC As String
' This is the subject of the Email
Public Subject As String
' This is the main content of the Email
Public Body As String
' If set to TRUE, the body of the Email will be treated as HTML
Public BodyIsHTML As Boolean
' If the Email is HTML, this specifies the base location/path/URL of all the images or links in the HTML body of the Email
' Example = "http://www.MyDomain.com/NewSite/"
Public HtmlBaseLocation As String
' The priority of the Email
Public PriorityLevel As CdoImportance
' The format of the Email (TEXT / MIME)
Public EmailFormat As CdoMailFormats
' The encoding to use with the Email
Public AttachmentEncoding As CdoEncodingMethod
' The full path to one or more attachment files (seperated by the PIPE "|" character)
Public AttachmentPath As String
' If set to true and an attachment path or object is specified, an attachment will be tacked onto the Email
Public AttachFile As Boolean
' This property gets the current version number for CDO (Collaboration Data Objects)
Public ReadOnly Property CdoVersion() As String
Get
On Error Resume Next
Dim objNewMail As CDONTS.NewMail
objNewMail = New CDONTS.NewMail
CdoVersion = objNewMail.Version
objNewMail = Nothing
End Get
End Property
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CLASS EVENT DECLARATIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Public Sub New()
' Set initial property values
Subject = "(none)"
Body = " "
PriorityLevel = CdoImportance.CdoNormal
EmailFormat = CdoMailFormats.CdoMailFormatMime
AttachmentEncoding = CdoEncodingMethod.CdoEncodingBase64
End Sub
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CLASS METHOD DECLARATIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
' This function uses the "NewMail" object to send a simple Email based on the parameters passed to it.
Public Function SendEmail(ByVal strFrom As String, _
ByVal strTO As String, _
Optional ByVal strCC As String = vbNullString, _
Optional ByVal strBCC As String = vbNullString, _
Optional ByVal strReplyTo As String = vbNullString, _
Optional ByVal strSubject As String = "", _
Optional ByVal strBody As String = "", _
Optional ByVal blnBodyIsHTML As Boolean = False, _
Optional ByVal udtPriorityLevel As CdoImportance = CdoImportance.CdoNormal, _
Optional ByRef Return_ErrNum As Int32 = 0, _
Optional ByRef Return_ErrDesc As String = "") As Boolean
On Error GoTo ErrorTrap
Dim objNewMail As CDONTS.NewMail
' Clear return variables
Return_ErrNum = 0
Return_ErrDesc = ""
' Make sure the minimum requirements for sending an Email are met
If Trim(strFrom) = "" Then
Return_ErrNum = -1 : Return_ErrDesc = "No FROM Email address specified"
Exit Function
ElseIf Trim(strTO) = "" Then
Return_ErrNum = -1 : Return_ErrDesc = "No TO Email address specified"
Exit Function
ElseIf (Trim(strSubject) = "" And Trim(strBody) = "") Then
Return_ErrNum = -1 : Return_ErrDesc = "No subject nor body specified to send the Email"
Exit Function
End If
If strSubject = "" Then strSubject = "(none)"
If strBody = "" Then strBody = " "
' Initialize the object that sends the Email
objNewMail = New CDONTS.NewMail
If objNewMail Is Nothing Then
Return_ErrNum = -1 : Return_ErrDesc = "Failed to create the NewMail object used to send the Email"
Exit Function
End If
' Set the Email object's properties
With objNewMail
.From = strFrom
.To = strTO
If strCC <> "" Then .Cc = strCC
If strBCC <> "" Then .Bcc = strBCC
If strReplyTo <> "" Then .Value("Reply-To") = strReplyTo
.Subject = strSubject
.Body = strBody
If blnBodyIsHTML = True Then
.BodyFormat = CdoBodyFormats.CdoBodyFormatHTML
.MailFormat = CdoMailFormats.CdoMailFormatMime
Else
.BodyFormat = CdoBodyFormats.CdoBodyFormatText
.MailFormat = CdoMailFormats.CdoMailFormatText
End If
.Importance = udtPriorityLevel
End With
' Send the Email
objNewMail.Send()
SendEmail = True
objNewMail = Nothing
Exit Function
ErrorTrap:
Return_ErrNum = Err.Number
Return_ErrDesc = Err.Description
Err.Clear()
If Return_ErrNum = 0 Or Return_ErrNum = 20 Then Resume Next
objNewMail = Nothing
End Function
' This function uses the "NewMail" object to send a complex Email based on the properties set within this class
Public Function SendEmailEx(Optional ByRef Return_ErrNum As Int32 = 0, _
Optional ByRef Return_ErrDesc As String = "") As Boolean
On Error GoTo ErrorTrap
Dim objNewMail As CDONTS.NewMail
Dim strFileName As String
Dim strAttachments() As String
Dim lngAttachCount As Int32
Dim lngCounter As Int32
' Clear return variables
Return_ErrNum = 0
Return_ErrDesc = ""
' Make sure the minimum requirements for sending an Email are met
If Trim(AddressFROM) = "" Then
Return_ErrNum = -1 : Return_ErrDesc = "No FROM Email address specified"
Exit Function
ElseIf Trim(AddressTO) = "" Then
Return_ErrNum = -1 : Return_ErrDesc = "No TO Email address specified"
Exit Function
ElseIf (Trim(Subject) = "" And Trim(Body) = "") Then
Return_ErrNum = -1 : Return_ErrDesc = "No subject nor body specified to send the Email"
Exit Function
ElseIf AttachFile = True Then
' Get the list of attachments and validate them
If Trim(AttachmentPath) = "" Then
AttachFile = False
Else
If SplitList(AttachmentPath, strAttachments, lngAttachCount, "|") = False Then
Return_ErrNum = -1 : Return_ErrDesc = "Could not get the list of attachments for the Email."
Exit Function
Else
If lngAttachCount > 0 Then
For lngCounter = 0 To lngAttachCount - 1
If IO.File.Exists(strAttachments(lngCounter)) = False Then
Return_ErrNum = -1 : Return_ErrDesc = "The file " & Chr(34) & strAttachments(lngCounter) & Chr(34) & " could not be found to attach to the Email"
Exit Function
End If
Next
Else
AttachFile = False
End If
End If
End If
End If
If Subject = "" Then Subject = "(none)"
If Body = "" Then Body = " "
' Initialize the object that sends the Email
objNewMail = New CDONTS.NewMail
If objNewMail Is Nothing Then
Return_ErrNum = -1 : Return_ErrDesc = "Failed to create the NewMail object used to send the Email"
Exit Function
End If
' Set the Email object's properties
With objNewMail
.From = AddressFROM
.To = AddressTO
If AddressCC <> "" Then .Cc = AddressCC
If AddressBCC <> "" Then .Bcc = AddressBCC
If AddressReplyTo <> "" Then .Value("Reply-To") = AddressReplyTo
.Subject = Subject
.Body = Body
If BodyIsHTML = True Then
.BodyFormat = CdoBodyFormats.CdoBodyFormatHTML
.MailFormat = CdoMailFormats.CdoMailFormatMime
Else
.BodyFormat = CdoBodyFormats.CdoBodyFormatText
.MailFormat = EmailFormat
End If
.Importance = PriorityLevel
End With
' Attach the specified attachment to the Email
If AttachFile = True Then
If lngAttachCount > 0 Then
If AttachmentEncoding = CdoEncodingMethod.CdoEncodingBase64 Then objNewMail.MailFormat = CdoMailFormats.CdoMailFormatMime
For lngCounter = 0 To lngAttachCount - 1
objNewMail.AttachFile(strAttachments(lngCounter), GetFileName(strAttachments(lngCounter)), AttachmentEncoding)
Next
End If
End If
' Send the Email
objNewMail.Send()
SendEmailEx = True
objNewMail = Nothing
Exit Function
ErrorTrap:
Return_ErrNum = Err.Number
Return_ErrDesc = Err.Description
Err.Clear()
If Return_ErrNum = 0 Or Return_ErrNum = 20 Then Resume Next
objNewMail = Nothing
End Function
' This function uses the "Session" object to send a complex Email based on the properties set within this class.
' NOTE: This function does not support the "Reply To" feature that the other "SendMail" functions do.
Public Function SendEmailAdv(ByVal strLoginSMTP_DisplayName As String, _
ByVal strLoginSMTP_EmailAddress As String, _
Optional ByRef Return_ErrNum As Int32 = 0, _
Optional ByRef Return_ErrDesc As String = "") As Boolean
On Error GoTo ErrorTrap
Dim objSession As CDONTS.Session
Dim objOutbox As CDONTS.Folder
Dim colMessages As CDONTS.Messages
Dim objMessage As CDONTS.Message
Dim colRecipients As CDONTS.Recipients
Dim colAttachments As CDONTS.Attachments
Dim strAddresses() As String
Dim lngAddrCount As Int32
Dim strAttachments() As String
Dim lngAttachCount As Int32
Dim lngCounter As Int32
' Clear return variables
Return_ErrNum = 0
Return_ErrDesc = ""
' Make sure the minimum requirements for sending an Email are met
If Trim(AddressFROM) = "" Then
Return_ErrNum = -1 : Return_ErrDesc = "No FROM Email address specified"
Exit Function
ElseIf Trim(AddressTO) = "" Then
Return_ErrNum = -1 : Return_ErrDesc = "No TO Email address specified"
Exit Function
ElseIf (Trim(Subject) = "" And Trim(Body) = "") Then
Return_ErrNum = -1 : Return_ErrDesc = "No subject nor body specified to send the Email"
Exit Function
ElseIf AttachFile = True Then
' Get the list of attachments and validate them
If Trim(AttachmentPath) = "" Then
AttachFile = False
Else
If SplitList(AttachmentPath, strAttachments, lngAttachCount, "|") = False Then
Return_ErrNum = -1 : Return_ErrDesc = "Could not get the list of attachments for the Email."
Exit Function
Else
If lngAttachCount > 0 Then
For lngCounter = 0 To lngAttachCount - 1
If IO.File.Exists(strAttachments(lngCounter)) = False Then
Return_ErrNum = -1 : Return_ErrDesc = "The file " & Chr(34) & strAttachments(lngCounter) & Chr(34) & " could not be found to attach to the Email"
Exit Function
End If
Next
Else
AttachFile = False
End If
End If
End If
End If
If Subject = "" Then Subject = "(none)"
If Body = "" Then Body = " "
' Initialize the object that sends the Email
objSession = New CDONTS.Session
If objSession Is Nothing Then
Return_ErrNum = -1 : Return_ErrDesc = "Failed to create the Session object to use in sending the Email"
GoTo CleanUp
End If
' Login to the SMTP/Exchange/POP3 server
objSession.LogonSMTP(strLoginSMTP_DisplayName, strLoginSMTP_EmailAddress)
' Get a reference to the OUTBOX so we can send an Email through it
objOutbox = objSession.GetDefaultFolder(CdoFolderTypes.CdoDefaultFolderOutbox)
If objOutbox Is Nothing Then
Return_ErrNum = -1 : Return_ErrDesc = "Failed to create the Outbox object to use in sending the Email"
GoTo CleanUp
End If
' Get a reference to the MESSAGES collection in the OUTBOX
colMessages = objOutbox.Messages
If colMessages Is Nothing Then
Return_ErrNum = -1 : Return_ErrDesc = "Failed to create the Messages collection to use in sending the Email"
GoTo CleanUp
End If
' Create a new message to send out
objMessage = colMessages.Add
If objMessage Is Nothing Then
Return_ErrNum = -1 : Return_ErrDesc = "Failed to create the Message object to send the Email"
GoTo CleanUp
End If
' Get a list of recipients so we can add new ones
colRecipients = objMessage.Recipients
If colRecipients Is Nothing Then
Return_ErrNum = -1 : Return_ErrDesc = "Failed to create the Recipients collection to send out the Email to"
GoTo CleanUp
End If
' Get all the addresses specified and add them to Recipients collection
If SplitList(AddressTO, strAddresses, lngAddrCount, ";") = True Then
If lngAddrCount > 0 Then
For lngCounter = 0 To lngAddrCount - 1
colRecipients.Add(, strAddresses(lngCounter), CdoRecipientTypes.CdoTo)
Next
End If
End If
If SplitList(AddressCC, strAddresses, lngAddrCount, ";") = True Then
If lngAddrCount > 0 Then
For lngCounter = 0 To lngAddrCount - 1
colRecipients.Add(, strAddresses(lngCounter), CdoRecipientTypes.CdoCc)
Next
End If
End If
If SplitList(AddressBCC, strAddresses, lngAddrCount, ";") = True Then
If lngAddrCount > 0 Then
For lngCounter = 0 To lngAddrCount - 1
colRecipients.Add(, strAddresses(lngCounter), CdoRecipientTypes.CdoBcc)
Next
End If
End If
' Set the properties of the Message object
With objMessage
.Subject = Subject
.Text = Body
If BodyIsHTML = True Then .HTMLText = Body
If HtmlBaseLocation <> "" Then .ContentBase = HtmlBaseLocation
If EmailFormat = CdoMailFormats.CdoMailFormatMime Then
.MessageFormat = CdoMessageFormats.CdoMime
Else
.MessageFormat = CdoMessageFormats.CdoText
End If
.Importance = PriorityLevel
End With
' Attach the specified attachment to the Email
If AttachFile = True Then
If AttachmentEncoding = CdoEncodingMethod.CdoEncodingBase64 Then objMessage.MessageFormat = CdoMessageFormats.CdoMime
' Get the attchments collection to work with
colAttachments = objMessage.Attachments
If colAttachments Is Nothing Then
Return_ErrNum = -1 : Return_ErrDesc = "Failed to create the attachments object to send out the Email to"
GoTo CleanUp
End If
' Attach the files to the Email
If lngAttachCount > 0 Then
For lngCounter = 0 To lngAttachCount - 1
colAttachments.Add(GetFileName(strAttachments(lngCounter)), CdoAttachmentTypes.CdoFileData, strAttachments(lngCounter))
Next
End If
End If
' Send the Email
objMessage.Send()
SendEmailAdv = True
CleanUp:
Erase strAddresses
Erase strAttachments
colAttachments = Nothing
colRecipients = Nothing
objMessage = Nothing
colMessages = Nothing
objOutbox = Nothing
If Not objSession Is Nothing Then
objSession.Logoff()
objSession = Nothing
End If
Exit Function
ErrorTrap:
Return_ErrNum = Err.Number
Return_ErrDesc = Err.Description
Err.Clear()
If Return_ErrNum = 0 Or Return_ErrNum = 20 Then Resume Next
GoTo CleanUp
End Function
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX PRIVATE FUNCTION DECLARATIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
' This function strips off the file name from a full path
Private Function GetFileName(ByVal strFullPath As String) As String
On Error Resume Next
Dim strLeft As String
Dim strRight As String
Dim strString As String
Dim lngCounter As Int32
' Validate the passed parameter
If Trim(strFullPath) = "" Then Exit Function
If InStr(strFullPath, "/") = 0 And InStr(strFullPath, "\") = 0 Then
GetFileName = strFullPath
Exit Function
End If
' Get the file name from the path
For lngCounter = 1 To Len(strFullPath)
strRight = Right(strFullPath, lngCounter)
strLeft = Left(strRight, 1)
If strLeft = "/" Or strLeft = "\" Then
GetFileName = strString
Exit Function
Else
strString = strLeft & strString
End If
Next
End Function
' This function takes the specified list (seperated by the specified split character) passed in via the
' strSplitList parameter and seperates them out. It returns them as a string array.
' "Why not just use the 'Split()' function?" Because VB5 (and earlier versions of IIS) doesn't have that
' function, and the return of 'Split()' is a VARIANT array... not a strictly cast array.
Private Function SplitList(ByVal strSplitList As String, _
ByRef Return_Items() As String, _
ByRef Return_Count As Int32, _
Optional ByVal strSplitChar As String = ";") As Boolean
On Error Resume Next
Dim strItem As String
Dim lngEnd As Int32
' Clear the return varaibles
Return_Count = 0
Erase Return_Items
' Validate the parameter passed
strSplitChar = Left(strSplitChar, 1)
strSplitList = Trim(strSplitList)
If strSplitList = "" Then
SplitList = True
Exit Function
ElseIf InStr(1, strSplitList, strSplitChar, vbTextCompare) = 0 Then
Return_Count = 1
ReDim Return_Items(0) 'As String
Return_Items(0) = strSplitList
SplitList = True
Exit Function
Else
If Right(strSplitList, 1) <> strSplitChar Then strSplitList = strSplitList & strSplitChar
End If
' Go through the list and get the addresses out
lngEnd = InStr(1, strSplitList, strSplitChar, vbTextCompare)
Do While lngEnd > 0
strItem = Mid(strSplitList, 1, (lngEnd - 1))
ReDim Preserve Return_Items(Return_Count) 'As String
Return_Items(Return_Count) = strItem
Return_Count = Return_Count + 1
strSplitList = Right(strSplitList, (Len(strSplitList) - Len(strItem)) - 1)
lngEnd = InStr(1, strSplitList, strSplitChar, vbTextCompare)
Loop
SplitList = True
End Function
End Class