Binaryworld - Sending Email Using CDO and MAPI ... [ VB -> Exteral Libs ]

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