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.