devxlogo

Sending Email Using CDO and MAPI

Sending Email Using CDO and MAPI

Sending emails via code used to be cool, but now it is a necessity. Below is code to send email via CDO. If the CDO call fails, it will send using MAPI. NOTE: You must have CDO for NT referenced in your project for this to work.

' Sends an email to the appropriate person(s)'' SendTo = List of email addresses separated by a semicolon.  Example:'                          [email protected]; [email protected]; [email protected]' Subject = Text that summarizes what the email is about' EmailText = Body of text that is the email' AttachmentPath = Directory in which the attachment resides' Attachment = File to send with the emailSub SendEmail(From As String, SendTo As String, Subject As String, _    EmailText As String, Optional AttachmentPath As String, _    Optional Attachment As String, Optional CC As String)    Const constRoutine As String = "SendEmail"    Dim strSendTo As String    Dim objSendMail As CDONTS.NewMail    Dim i As Integer    On Error GoTo TryMAPI        'Do not cause the user a major error, just log the error and keep going    If SendTo = "" Then Exit Sub    Set objSendMail = New CDONTS.NewMail    With objSendMail        On Error Resume Next        .From = From        If CC <> "" Then            .CC = CC        End If        On Error GoTo ErrorHandler        .To = SendTo        .Subject = Subject        .Body = EmailText        AttachmentPath = Trim$(AttachmentPath)                If AttachmentPath <> "" Then            If Right$(AttachmentPath, 1) <> "" Then                AttachmentPath = AttachmentPath & ""            End If            .AttachFile (AttachmentPath & Attachment)        End If        .Send    End With    GoTo ExitMeTryMAPI:    On Error GoTo ErrorHandler    'If CDO fails, try MAPI    If CC <> "" Then        strSendTo = SendTo & "; " & CC    Else        strSendTo = SendTo    End If    Call SendEmailMAPI(SendTo:=strSendTo, Subject:=Subject, _        EmailText:=EmailText)ExitMe:    Set objSendMail = Nothing    Exit SubErrorHandler:    Err.Raise Err.Number, Err.Source, Err.Description    Resume ExitMeEnd Sub' Sends an email to the appropriate person(s).' SendTo = List of email addresses separated by a semicolon.  Example:'                 [email protected]; [email protected]; [email protected]' Subject = Text that summarizes what the email is about' EmailText = Body of text that is the email' AttachmentPath = Directory in which the attachment resides' Attachment = File to send with the emailSub SendEmailMAPI(SendTo As String, Subject As String, EmailText As String, _    Optional AttachmentPath As String, Optional Attachment As String)   Const constRoutine As String = "SendEmailMAPI"   Dim intStart As Integer   Dim strSendTo As String   Dim intEnd As Integer   Dim i As Integer   On Error GoTo ErrorHandler      If frmEmailCommon.MAPISession.SessionID = 0 Then      frmEmailCommon.MAPISession.SignOn   End If   If SendTo = "" Then Exit Sub   With frmEmailCommon.MAPIMessages      .SessionID = frmEmailCommon.MAPISession.SessionID      .Compose      'Make sure that the SendTo always has a trailing semi-colon (makes it       ' easier below)      'Strip out any spaces between names for consistency      For i = 1 To Len(SendTo)         If Mid$(SendTo, i, 1) <> " " Then            strSendTo = strSendTo & Mid$(SendTo, i, 1)         End If      Next i      SendTo = strSendTo      If Right$(SendTo, 1) <> ";" Then         SendTo = SendTo & ";"      End If      'Format each recipient, each are separated by a semi-colon, like this:      '  [email protected];[email protected]; [email protected];      intEnd = InStr(1, SendTo, ";")      .RecipAddress = Mid$(SendTo, 1, intEnd - 1)      .ResolveName      intStart = intEnd + 1      Do         intEnd = InStr(intStart, SendTo, ";")         If intEnd = 0 Then            Exit Do         Else            .RecipIndex = .RecipIndex + 1            .RecipAddress = Mid$(SendTo, intStart, intEnd - intStart)            .ResolveName         End If         intStart = intEnd + 1      Loop      .MsgSubject = Subject      .MsgNoteText = EmailText      If Left$(Attachment, 1) = "" Then         Attachment = Mid$(Attachment, 2, Len(Attachment))      End If      If Attachment <> "" Then         If Right$(AttachmentPath, 1) = "" Then            .AttachmentPathName = AttachmentPath & Attachment         Else            .AttachmentPathName = AttachmentPath & "" & Attachment         End If        .AttachmentName = Attachment      End If      .Send False   End WithExitMe:   Exit SubErrorHandler:   Err.Raise Err.Number, m_constPgm & constRoutine, Err.Description   Resume ExitMeEnd Sub


This tip has been brought to you by Pragmatic Software Co. Inc, the creators of Defect Tracker, the tool of choice for tracking functional specifications, test cases and software bugs. Learn more at http://www.DefectTracker.com. Affiliate program also available at http://www.PragmaticSW.com/AffiliateSignup.

See also  How to Create and Deploy QR Codes Online: A Comprehensive Guide
devxblackblue

About Our Editorial Process

At DevX, we’re dedicated to tech entrepreneurship. Our team closely follows industry shifts, new products, AI breakthroughs, technology trends, and funding announcements. Articles undergo thorough editing to ensure accuracy and clarity, reflecting DevX’s style and supporting entrepreneurs in the tech sphere.

See our full editorial policy.

About Our Journalist