VB and VBA Users Source Code: Send an email using Outlook
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Send an email using Outlook
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Monday, June 18, 2001
Hits:
1250
Category:
Internet/Remote Comms
Article:
The following code demonstrates how to send an email using Outlook: Option Explicit 'Purpose : Sends a text email using Outlook 'Inputs : sTo A semi collan seperate list of email addresses to send the mail to. ' sSubject The subject of the email. ' sBody The body of the email. ' [sAttachments] If specified is a semi collan deliminated list of the files to attach. ' eg. "C:\autoexec.bat;C:\config.sys" ' [sAttachmentNames] If specified is a semi collan deliminated list of the display names for ' the files in the "sAttachments" variable. eg "Auto Exec File;Config Sys File" ' [bPreviewMail] If True the mail is shown to the user before they choose whether to send it or not. 'Outputs : Returns True on success 'Author : Andrew Baker 'Date : 25/03/2000 'Notes : Function OutlookSendMail(sTo As String, sSubject As String, sBody As String, Optional sAttachments As String = "", Optional sAttachmentNames As String = "", Optional bPreviewMail As Boolean = False) As Boolean Dim oOutlookApp As Object 'Outlook.Application Dim olMail As Object 'Outlook.MailItem Dim oInbox As Object Dim asAttachments() As String, asAttachmentNames() As String Dim lThisAttachment As Long, lLastAttachName As Long Dim asRecipients() As String, lThisRecip As Long On Error Resume Next 'Get a reference to an open copy of outlook Set oOutlookApp = GetObject(, "Outlook.Application") If oOutlookApp Is Nothing = True Then 'Outlook is not open, create a new outlook Set oOutlookApp = CreateObject("Outlook.Application") End If On Error GoTo ErrFailed If (oOutlookApp Is Nothing) = False Then 'Create a new mail item Set oInbox = oOutlookApp.Session.GetDefaultFolder(6) 'olFolderInbox Set olMail = oOutlookApp.CreateItem(0) 'olMailItem 'Set the mail fields olMail.Subject = sSubject 'Add the list of recipients asRecipients = Split(sTo, ";") For lThisRecip = 0 To UBound(asRecipients) olMail.Recipients.Add Trim$(asRecipients(lThisRecip)) Next olMail.Body = sBody If Len(sAttachments) > 0 Then 'Add attachments On Error Resume Next asAttachments = Split(sAttachments, ";") If Len(sAttachmentNames) Then asAttachmentNames = Split(sAttachmentNames, ";") lLastAttachName = UBound(asAttachmentNames) Else lLastAttachName = -1 End If For lThisAttachment = 0 To UBound(asAttachments) 'Check the attachment exists asAttachments(lThisAttachment) = Trim$(asAttachments(lThisAttachment)) If Len(Dir$(asAttachments(lThisAttachment))) > 0 Then 'Attachment exists, add it With olMail.Attachments.Add(asAttachments(lThisAttachment), 1) 'Where 1 = olByValue (Embed attachment in the item) If lThisAttachment <= lLastAttachName Then .DisplayName = asAttachmentNames(lThisAttachment) End If End With End If Next On Error GoTo ErrFailed End If If bPreviewMail Then 'Show the mail to the user and let them choose to send it olMail.Display vbModal Else 'Send Mail olMail.Send End If 'Clear object pointers Set olMail = Nothing Set oInbox = Nothing Set oOutlookApp = Nothing OutlookSendMail = True Else 'Failed to create an outlook OutlookSendMail = False End If Exit Function ErrFailed: 'Failed to send mail Debug.Print "Error in OutlookSendMail: " & Err.Description If (olMail Is Nothing) = False Then olMail.Delete End If Set olMail = Nothing Set oOutlookApp = Nothing OutlookSendMail = False End Function 'Demonstration routine Sub Test() If OutlookSendMail("myname@somewhere.com;myname@somewhere2.com", "Test Subject", "Test Body", "C:\clsReportEngine.cls", "Report Class", True) = True Then MsgBox "Sent email!", vbInformation Else MsgBox "Failed to send email!", vbInformation End If End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
