Login | Register   
LinkedIn
Google+
Twitter
RSS Feed
Download our iPhone app
TODAY'S HEADLINES  |   ARTICLE ARCHIVE  |   FORUMS  |   TIP BANK
Browse DevX
Sign up for e-mail newsletters from DevX


Tip of the Day
Language: VB5,VB6
Expertise: Intermediate
Jul 22, 2000

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:
'                          sm@xyz.com; steve@work.com; jane@home.com
' 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 email

Sub 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 ExitMe

TryMAPI:
    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 Sub

ErrorHandler:
    Err.Raise Err.Number, Err.Source, Err.Description
    Resume ExitMe

End Sub

' Sends an email to the appropriate person(s).
' SendTo = List of email addresses separated by a semicolon.  Example:
'                 sm@xyz.com; steve@work.com; jane@home.com
' 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 email

Sub 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:
      '  steve.miller@aol.com;sm@psc.com; sm@teletech.com;
      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 With

ExitMe:
   Exit Sub

ErrorHandler:
   Err.Raise Err.Number, m_constPgm & constRoutine, Err.Description
   Resume ExitMe

End 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.
Steve Miller
 
Comment and Contribute

 

 

 

 

 


(Maximum characters: 1200). You have 1200 characters left.

 

 

Sitemap
Thanks for your registration, follow us on our social networks to keep up-to-date