Atlanta Custom Software Development 

 
   Search        Code/Page
 

User Login
Email

Password

 

Forgot the Password?
Services
» Web Development
» Maintenance
» Data Integration/BI
» Information Management
Programming
  Database
Automation
OS/Networking
Graphics
Links
Tools
» Regular Expr Tester
» Free Tools

Sending Email Using CDO and MAPI

Total Hit ( 2158)

Rate this article:     Poor     Excellent 

 Submit Your Question/Comment about this article

Rating


 


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.

Click here to copy the following block
' 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


Submitted By : Nayan Patel  (Member Since : 5/26/2004 12:23:06 PM)

Job Description : He is the moderator of this site and currently working as an independent consultant. He works with VB.net/ASP.net, SQL Server and other MS technologies. He is MCSD.net, MCDBA and MCSE. In his free time he likes to watch funny movies and doing oil painting.
View all (893) submissions by this author  (Birth Date : 7/14/1981 )


Home   |  Comment   |  Contact Us   |  Privacy Policy   |  Terms & Conditions   |  BlogsZappySys

© 2008 BinaryWorld LLC. All rights reserved.