VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "cCDONTS" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit '============================================================================================================= ' ' cCDONTS Class Module ' -------------------- ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Created On : April 26, 2002 ' Last Update : April 26, 2002 ' ' VB Versions : 5.0 / 6.0 ' ' 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 ' ' 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 Long ' 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 Long ' Dim strErrDesc As String ' ' Set MAIL = New cCDONTS ' MsgBox "CDO Version = " & MAIL.CdoVersion ' With MAIL ' .AddresFROM = "BillGates@Microsoft.com" ' .AddresTO = "Everyone@TheWorld.org" ' .AddresCC = "Everyone@TheGovernment.gov" ' .AddresReplyTo = "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. ' '============================================================================================================= ' CDO Error Constants Private Const CdoE_CALL_FAILED As Long = &H80004005 Private Const CdoE_NOT_ENOUGH_MEMORY As Long = &H8007000E Private Const CdoE_INVALID_PARAMETER As Long = &H80070057 Private Const CdoE_INTERFACE_NOT_SUPPORTED As Long = &H80004002 Private Const CdoE_NO_ACCESS As Long = &H80070005 Private Const CdoE_NO_SUPPORT As Long = &H80040102 Private Const CdoE_BAD_CHARWIDTH As Long = &H80040103 Private Const CdoE_STRING_TOO_LONG As Long = &H80040105 Private Const CdoE_UNKNOWN_FLAGS As Long = &H80040106 Private Const CdoE_INVALID_ENTRYID As Long = &H80040107 Private Const CdoE_INVALID_OBJECT As Long = &H80040108 Private Const CdoE_OBJECT_CHANGED As Long = &H80040109 Private Const CdoE_OBJECT_DELETED As Long = &H8004010A Private Const CdoE_BUSY As Long = &H8004010B Private Const CdoE_NOT_ENOUGH_DISK As Long = &H8004010D Private Const CdoE_NOT_ENOUGH_RESOURCES As Long = &H8004010E Private Const CdoE_NOT_FOUND As Long = &H8004010F Private Const CdoE_VERSION As Long = &H80040110 Private Const CdoE_LOGON_FAILED As Long = &H80040111 Private Const CdoE_SESSION_LIMIT As Long = &H80040112 Private Const CdoE_USER_CANCEL As Long = &H80040113 Private Const CdoE_UNABLE_TO_ABORT As Long = &H80040114 Private Const CdoE_NETWORK_ERROR As Long = &H80040115 Private Const CdoE_DISK_ERROR As Long = &H80040116 Private Const CdoE_TOO_COMPLEX As Long = &H80040117 Private Const CdoE_BAD_COLUMN As Long = &H80040118 Private Const CdoE_EXTENDED_ERROR As Long = &H80040119 Private Const CdoE_COMPUTED As Long = &H8004011A Private Const CdoE_CORRUPT_DATA As Long = &H8004011B Private Const CdoE_UNCONFIGURED As Long = &H8004011C Private Const CdoE_FAILONEPROVIDER As Long = &H8004011D Private Const CdoE_UNKNOWN_CPID As Long = &H8004011E Private Const CdoE_UNKNOWN_LCID As Long = &H8004011F Private Const CdoE_PASSWORD_CHANGE_REQUIRED As Long = &H80040120 Private Const CdoE_PASSWORD_EXPIRED As Long = &H80040121 Private Const CdoE_INVALID_WORKSTATION_ACCOUNT As Long = &H80040122 Private Const CdoE_INVALID_ACCESS_TIME As Long = &H80040123 Private Const CdoE_ACCOUNT_DISABLED As Long = &H80040124 Private Const CdoE_END_OF_SESSION As Long = &H80040200 Private Const CdoE_UNKNOWN_ENTRYID As Long = &H80040201 Private Const CdoE_MISSING_REQUIRED_COLUMN As Long = &H80040202 Private Const CdoE_BAD_VALUE As Long = &H80040301 Private Const CdoE_INVALID_TYPE As Long = &H80040302 Private Const CdoE_TYPE_NO_SUPPORT As Long = &H80040303 Private Const CdoE_UNEXPECTED_TYPE As Long = &H80040304 Private Const CdoE_TOO_BIG As Long = &H80040305 Private Const CdoE_DECLINE_COPY As Long = &H80040306 Private Const CdoE_UNEXPECTED_ID As Long = &H80040307 Private Const CdoE_UNABLE_TO_COMPLETE As Long = &H80040400 Private Const CdoE_TIMEOUT As Long = &H80040401 Private Const CdoE_TABLE_EMPTY As Long = &H80040402 Private Const CdoE_TABLE_TOO_BIG As Long = &H80040403 Private Const CdoE_INVALID_BOOKMARK As Long = &H80040405 Private Const CdoE_WAIT As Long = &H80040500 Private Const CdoE_CANCEL As Long = &H80040501 Private Const CdoE_NOT_ME As Long = &H80040502 Private Const CdoE_CORRUPT_STORE As Long = &H80040600 Private Const CdoE_NOT_IN_QUEUE As Long = &H80040601 Private Const CdoE_NO_SUPPRESS As Long = &H80040602 Private Const CdoE_COLLISION As Long = &H80040604 Private Const CdoE_NOT_INITIALIZED As Long = &H80040605 Private Const CdoE_NON_STANDARD As Long = &H80040606 Private Const CdoE_NO_RECIPIENTS As Long = &H80040607 Private Const CdoE_SUBMITTED As Long = &H80040608 Private Const CdoE_HAS_FOLDERS As Long = &H80040609 Private Const CdoE_HAS_MESSAGES As Long = &H8004060A Private Const CdoE_FOLDER_CYCLE As Long = &H8004060B Private Const CdoE_AMBIGUOUS_RECIP As Long = &H80040700 Private Const CdoW_NO_SERVICE As Long = &H40203 Private Const CdoW_ERRORS_RETURNED As Long = &H40380 Private Const CdoW_POSITION_CHANGED As Long = &H40481 Private Const CdoW_APPROX_COUNT As Long = &H40482 Private Const CdoW_CANCEL_MESSAGE As Long = &H40580 Private Const CdoW_PARTIAL_COMPLETION As Long = &H40680 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CLASS PROPERTY DECLARATIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ' Specifies who is sending the Email. This can not have multiple addresses. Public AddresFROM 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. Public AddresReplyTo As String ' Main recipient(s) of the Email. If using multiple addresses, seperate them with a semicolon (;) Public AddresTO As String ' Recipient(s) to "CARBON COPY" the Email to. If using multiple addresses, seperate them with a semicolon (;) Public AddresCC As String ' Recipient(s) to "BLIND CARBON COPY" the Email to. If using multiple addresses, seperate them with a semicolon (;) Public AddresBCC 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 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 Property Get CdoVersion() As String On Error Resume Next Dim objNewMail As CDONTS.NewMail Set objNewMail = New CDONTS.NewMail CdoVersion = objNewMail.Version Set objNewMail = Nothing End Property 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CLASS EVENT DECLARATIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX Private Sub Class_Initialize() ' Set initial property values Subject = "(none)" Body = " " PriorityLevel = CdoNormal EmailFormat = CdoMailFormatMime AttachmentEncoding = 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, _ Optional ByVal udtPriorityLevel As CdoImportance = CdoNormal, _ Optional ByRef Return_ErrNum As Long, _ 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 Set 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" GoTo CleanUp 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 = CdoBodyFormatHTML .MailFormat = CdoMailFormatMime Else .BodyFormat = CdoBodyFormatText .MailFormat = CdoMailFormatText End If .Importance = udtPriorityLevel End With ' Send the Email objNewMail.send SendEmail = True CleanUp: Set 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 GoTo CleanUp 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 Long, _ 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 Long Dim lngCounter As Long ' Clear return variables Return_ErrNum = 0 Return_ErrDesc = "" ' Make sure the minimum requirements for sending an Email are met If Trim(AddresFROM) = "" Then Return_ErrNum = -1: Return_ErrDesc = "No FROM Email address specified" Exit Function ElseIf Trim(AddresTO) = "" 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 Dir(strAttachments(lngCounter), vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) = "" 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 Set 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" GoTo CleanUp End If ' Set the Email object's properties With objNewMail .From = AddresFROM .to = AddresTO If AddresCC <> "" Then .Cc = AddresCC If AddresBCC <> "" Then .Bcc = AddresBCC If AddresReplyTo <> "" Then .Value("Reply-To") = AddresReplyTo .Subject = Subject .Body = Body If BodyIsHTML = True Then .BodyFormat = CdoBodyFormatHTML .MailFormat = CdoMailFormatMime Else .BodyFormat = CdoBodyFormatText .MailFormat = EmailFormat End If .Importance = PriorityLevel End With ' Attach the specified attachment to the Email If AttachFile = True Then If AttachmentEncoding = CdoEncodingBase64 Then objNewMail.MailFormat = CdoMailFormatMime If lngAttachCount > 0 Then 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 CleanUp: Set 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 GoTo CleanUp 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 Long, _ 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 Long Dim strAttachments() As String Dim lngAttachCount As Long Dim lngCounter As Long ' Clear return variables Return_ErrNum = 0 Return_ErrDesc = "" ' Make sure the minimum requirements for sending an Email are met If Trim(AddresFROM) = "" Then Return_ErrNum = -1: Return_ErrDesc = "No FROM Email address specified" Exit Function ElseIf Trim(AddresTO) = "" 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 Dir(strAttachments(lngCounter), vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) = "" 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 Set 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 Set objOutbox = objSession.GetDefaultFolder(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 Set 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 Set 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 Set 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(AddresTO, strAddresses, lngAddrCount, ";") = True Then If lngAddrCount > 0 Then For lngCounter = 0 To lngAddrCount - 1 colRecipients.Add , strAddresses(lngCounter), CdoTo Next End If End If If SplitList(AddresCC, strAddresses, lngAddrCount, ";") = True Then If lngAddrCount > 0 Then For lngCounter = 0 To lngAddrCount - 1 colRecipients.Add , strAddresses(lngCounter), CdoCc Next End If End If If SplitList(AddresBCC, strAddresses, lngAddrCount, ";") = True Then If lngAddrCount > 0 Then For lngCounter = 0 To lngAddrCount - 1 colRecipients.Add , strAddresses(lngCounter), 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 .ContentLocation = HtmlBaseLocation If EmailFormat = CdoMailFormatMime Then .MessageFormat = CdoMime Else .MessageFormat = CdoText End If .Importance = PriorityLevel End With ' Attach the specified attachment to the Email If AttachFile = True Then If AttachmentEncoding = CdoEncodingBase64 Then objMessage.MessageFormat = CdoMime ' Get the attchments collection to work with Set 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)), CdoFileData, strAttachments(lngCounter) Next End If End If ' Send the Email objMessage.send SendEmailAdv = True CleanUp: Erase strAddresses Erase strAttachments Set colAttachments = Nothing Set colRecipients = Nothing Set objMessage = Nothing Set colMessages = Nothing Set objOutbox = Nothing If Not objSession Is Nothing Then objSession.Logoff Set 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 Long ' 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 Long, _ Optional ByVal strSplitChar As String = ";") As Boolean On Error Resume Next Dim strItem As String Dim lngEnd As Long ' 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