INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

Outlook Email Wrapper Class

How do I Email via Microsoft Outlook and save sent .msg Email file to a specific location. by 1DMF
Posted: 26 Jul 13 (Edited 31 Jul 13)

Hi All,

I have created a new email wrapper class to help with sending emails through Microsoft Outlook via VBA and included the ability to save the sent email to your computer's hard drive.

This new email wrapper class (clsEmailWrapperII) has many improvements on the original FAQ I wrote for replacing CDO 1.2.1 FAQ705-7446: How do I replace CDO 1.2.1 with Outlook Object Model (migrating from Office 2003 to Office 2007/2010 ),
this new class includes not only checking that Outlook is available and open, but opens it if it closed, as well as includes additional functionality and far superior error handling.

I have been running the clsEmailWrapperII class in production for about a month and so far it has been performing well, but as always, if you find any bugs or have suggestions for
improvements please let me know.

OK, here comes the science bit...

Class Name : clsEmailWrapperII

CODE

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsEmailWrapperII"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' Sleep API
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

' Instance attribute emailwrapper components
Private sSubject As String
Private cTO As New Collection
Private cBCC As New Collection
Private cCC As New Collection
Private sBody As String
Private cFiles As New Collection
Private cItems As New Collection
Private cItemTypes As New Collection
Private sDraftsID As String
Private iTimeOut As Integer
Private bShowProgress As Boolean
Private sEmailRef As String
Private oProgress As Object
Private cProgressMsg As New Collection
Private bSave As Boolean
Private iMaxSentItems As Integer
Private iTimeOutCnt As Integer
Private sSender As String

' Errors / Status
Private oErrors As Object
Private oStatus As Object

' Outlook object
Private oApp As Object
Private oMsg As Object

' Constants
Const olMailItem As Integer = 0
Const olTO As Integer = 1
Const olCC As Integer = 2
Const olBCC As Integer = 3
Const olEmailMsg As Integer = 3
Const olOutbox As Integer = 4
Const olSentItems As Integer = 5
Const olText As Integer = 1

Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"

Private Sub Class_Initialize()

    ' Initialise vars
    sDraftsID = "" ' Email ID
    sEmailRef = "" ' Email Reference
    iMaxSentItems = 10 ' Sent items history range default
    iTimeOut = 300 ' Timeout default
    iTimeOutCnt = 0 ' Current timeout counter
    sSender = "" ' Sender email
    
    ' Internal error codes
    Set oErrors = CreateObject("Scripting.Dictionary")
    oErrors.Add 0, "No errors"
    oErrors.Add 1, "Can't open Outlook, process aborted!"
    oErrors.Add 2, "Failed to create email."
    oErrors.Add 3, "Failed to display email."
    oErrors.Add 4, "Failed to send email."
    oErrors.Add 5, "Failed to save email."
    oErrors.Add 6, "Failed to delete email from drafts."
    oErrors.Add 7, "Failed to get email from drafts."
    oErrors.Add 8, "Can't save email, no email reference is available."
    oErrors.Add 9, "Can't save email, email is still in drafts."
    oErrors.Add 10, "Can't save email, timeout reached!"
    oErrors.Add 11, "Can't save email, file path doesn't exist!"
    oErrors.Add 12, "Invalid drive letter for saving email"
    oErrors.Add 99, "Internal system error, seek support!"
        
    ' Status
    Set oStatus = CreateObject("Scripting.Dictionary")
    oStatus.Add "OK", True
    oStatus.Add "Error", 0
    oStatus.Add "Msg", ""
    
    ' Progress window
    bShowProgress = True
    Set oProgress = CreateObject("Scripting.Dictionary")
    oProgress.Add "Msg", cProgressMsg
    Call InitProgress("Progress_Info", "Progress", False, True)
    
End Sub

Private Sub Class_Terminate()

On Error Resume Next
    
    Call AddProgress("Email processing complete.")
    
    ' Close progress window
    If oProgress.Item("Close") Then
        DoCmd.Close acForm, oProgress.Item("Frm")
    End If

End Sub

' GETTER ACCESSOR METHODS

' Get internal error description
Public Property Get ErrorDesc() As String
    ErrorDesc = oErrors.Item(oStatus.Item("Error"))
End Property

' Get error code
Public Property Get ErrorCode() As Integer
    ErrorCode = oStatus.Item("Error")
End Property

' Get OK status
Public Property Get OK() As Boolean
    OK = oStatus.Item("OK")
End Property

' Get status messgage
Public Property Get StatusMsg() As String
    StatusMsg = oStatus.Item("Msg")
End Property

' Get show progress
Public Property Get ShowProgress() As Boolean
    ShowProgress = bShowProgress
End Property

' Get progress messages
Public Property Get ProgressMsg() As Collection
    Set ProgressMsg = oProgress.Item("Msg")
End Property

' Get email body
Public Property Get Body() As String
    Body = sBody
End Property

' Get timeout
Public Property Get Timeout() As Integer
    Timeout = iTimeOut
End Property

' Get email subject
Public Property Get Subject() As String
    Subject = sSubject
End Property

' Get email reference
Public Property Get EmailRef() As String
    EmailRef = sEmailRef
End Property

' Get draft email ID
Public Property Get DraftsID() As String
    DraftsID = sDraftsID
End Property

' Get sent items range
Public Property Get MaxSentItems() As Integer
    MaxSentItems = iMaxSentItems
End Property

' Get Sender Property
Public Property Get Sender() As String
    Sender = sSender
End Property


' SETTER ACCESSOR METHODS

' Set email subject
Public Property Let Subject(aValue As String)
    sSubject = aValue
End Property

' Set timeout (in seconds)
Public Property Let Timeout(aValue As Integer)
    iTimeOut = aValue
End Property

' Set email body
Public Property Let Body(aValue As String)
    sBody = aValue
End Property

' Set email reference
Public Property Let EmailRef(aValue As String)
    sEmailRef = aValue
End Property

' Set sent items range
Public Property Let MaxSentItems(aValue As Integer)
    iMaxSentItems = aValue
End Property

' Set Sender Property
Public Property Let Sender(aValue As String)
    sSender = aValue
End Property

' Set show progress
Public Property Let ShowProgress(aValue As Boolean)
    bShowProgress = aValue
End Property

' Add TO recipient
Public Sub AddTO(sRecip As String)
    cTO.Add (sRecip)
End Sub

' Add BCC recipient
Public Sub AddBCC(sRecip As String)
    cBCC.Add (sRecip)
End Sub

' Add CC recipient
Public Sub AddCC(sRecip As String)
    cCC.Add (sRecip)
End Sub

' Add file attachment
Public Sub AddAttachment(file As String)
    cFiles.Add (file)
End Sub

' Add inline attachment item and type
Public Sub AddInline(i As String, t As String)
    cItems.Add (i)
    cItemTypes.Add (t)
End Sub

' Clear progress messages
Public Sub ClearProgress()
    Set oProgress.Item("Msg") = New Collection
End Sub

' Clear TO recipients
Public Sub ClearTO()
    Set cTO = New Collection
End Sub

' Clear CC recipients
Public Sub ClearCC()
    Set cCC = New Collection
End Sub

' Clear BCC recipients
Public Sub ClearBCC()
    Set cBCC = New Collection
End Sub

' Clear TO recipients
Public Sub ClearRecips()
    Me.ClearTO
    Me.ClearCC
    Me.ClearBCC
End Sub

' CLASS PUBLIC METHODS

' Create email routine
Public Sub Create()
    
On Error GoTo Create_Email_Error
    
    Dim olAttach As Object
    Dim oAttach As Object
    Dim iCnt As Integer
    Dim oRecip As Object
    Dim oPA As Object
    Dim vEml As Variant
    Dim vAtt As Variant
    
    ' Reset status
    Call ResetStatus
    
    ' Clear save flag
    bSave = False
    
    ' Check outlook open and create outlook object
    If CheckOutlook And CreateOutlook Then
    
        ' Create new mail item
        Set oMsg = oApp.CreateItem(olMailItem)
        
        Call AddProgress("Creating email, please wait.")
        
        With oMsg
            
            ' Add TO recipients
            If cTO.Count > 0 Then
                Call AddProgress("Adding TO recipients.")
                For Each vEml In cTO
                    Set oRecip = .Recipients.Add(vEml)
                    oRecip.Type = olTO
                Next
            End If
            
            ' Add CC recipients
            If cCC.Count > 0 Then
                Call AddProgress("Adding CC recipients.")
                For Each vEml In cCC
                    Set oRecip = .Recipients.Add(vEml)
                    oRecip.Type = olCC
                Next
            End If
            
            ' Add BCC recipients
            If cBCC.Count > 0 Then
                Call AddProgress("Adding BCC recipients.")
                For Each vEml In cBCC
                    Set oRecip = .Recipients.Add(vEml)
                    oRecip.Type = olBCC
                Next
            End If
            
            ' Set email subject
            Call AddProgress("Adding email subject.")
            .Subject = Nz(sSubject, "")
            
            ' Set body HTML
            Call AddProgress("Adding email body.")
            .HTMLBody = Nz(sBody, "")
            
            ' add email reference
            If sEmailRef <> "" Then
                Call AddProgress("Adding email reference.")
                .UserProperties.Add "EmailRef", olText
                .UserProperties.Item("EmailRef").Value = sEmailRef
                bSave = True
            End If
            
            ' check for sender address
            If Sender <> "" Then
                .SentOnBehalfOfName = Sender
            End If
            
        End With
        
        ' Clear recipient object
        Set oRecip = Nothing
            
        ' Check items for mime encoding
        If cItems.Count > 0 Then
            Call AddProgress("Adding inline attachments.")
            ' Attach items
            Set olAttach = oMsg.Attachments
            For iCnt = 1 To cItems.Count
                Set oAttach = olAttach.Add(cItems.Item(iCnt))
                Set oPA = oAttach.PropertyAccessor
                oPA.SetProperty PR_ATTACH_MIME_TAG, cItemTypes.Item(iCnt)
                oPA.SetProperty PR_ATTACH_CONTENT_ID, "item" & iCnt
                oPA.SetProperty PR_ATTACHMENT_HIDDEN, True
            Next
                       
        End If
            
        ' Add normal file attachments
        If cFiles.Count > 0 Then
            Call AddProgress("Adding standard attachments.")
            For Each vAtt In cFiles
                oMsg.Attachments.Add (vAtt)
            Next
        End If
        
        ' Save email
        Call AddProgress("Saving email to drafts.", True)
        oMsg.Save
        
        sDraftsID = oMsg.EntryID
        
    End If
    
Exit_Create_Email:

    ' clean up objects
    Set oAttach = Nothing
    Set oPA = Nothing
    Set olAttach = Nothing
    Set vEml = Nothing
    Set vAtt = Nothing
    Set oMsg = Nothing
    Set oApp = Nothing
    
    Exit Sub
    
Create_Email_Error:

    If Err.Number = 287 Then
        ' Can't open Outlook
        Call AddError(1)
    Else
        ' Failed to create email
        Call AddError(2, Err.Description)
    End If
    
    ' Clean up Outlook email
    If Not oMsg Is Nothing Then
        Me.Delete
    End If
    
    Resume Exit_Create_Email
    
End Sub

' Display email routine
Public Sub Display()

On Error GoTo Display_Email_Error

    ' Get email
    If GetEmail Then

        ' Add progress
        Call AddProgress("Displaying email.", True)
        
        ' Display email
        oMsg.Display
        
    End If
    
Exit_Display_Email:
    
    ' Clear Outlook email objects
    Call ClearOutlook
    
    Exit Sub
    
Display_Email_Error:
    
    Call AddError(3, Err.Description)
    Resume Exit_Display_Email

End Sub

' Send email routine
Public Sub Send()

On Error GoTo Send_Email_Error

    ' Get email
    If GetEmail Then
    
        ' Add progress
        Call AddProgress("Sending email, please wait.")
    
        ' Send email
        oMsg.Send
        
    End If
    
Exit_Send_Email:

    ' Clear Outlook email objects
    Call ClearOutlook
    
    Exit Sub
    
Send_Email_Error:

    Call AddError(4, Err.Description)
    Resume Exit_Send_Email

End Sub

' Delete email routine
Public Sub Delete()

On Error GoTo Delete_Email_Error

    ' Get email
    If GetEmail Then
    
        ' Delete email
        oMsg.Delete
    
        ' Add progress
        Call AddProgress("Email has been deleted.")
        
    End If
    
Exit_Delete_Email:

    ' Clear Outlook email objects
    Call ClearOutlook
    Exit Sub
    
Delete_Email_Error:

    Call AddError(6, Err.Description)
    Resume Exit_Delete_Email

End Sub

' Save email routine
Public Sub Save(ByVal sDestPath As String, ByVal sFileName As String, Optional bCreate As Boolean = False)

On Error GoTo Save_Email_Error

    Dim sDest As String

    ' Reset timeout counter
    iTimeOutCnt = 0
    
    ' Reset status
    Call ResetStatus
    
    ' Check if save possible
    If Not bSave Or Nz(sEmailRef, "") = "" Then
        Call AddError(8)
    Else

        ' Check email in drafts - can't save
        If Me.OK And GetEmail Then
            Call AddError(9)
        Else
        
            ' So far so good - reset status and continue
            Call ResetStatus
        
            ' Check outbox and see if email is still sending
            Do While CheckOutbox And iTimeOutCnt <= iTimeOut
                Call AddProgress("Still sending email, please wait.")
                iTimeOutCnt = iTimeOutCnt + 3
                Sleep 3000
            Loop
                        
            ' Try to get email from sent items
            Do While Me.OK And iTimeOutCnt <= iTimeOut And Not GetSentEmail
                Call AddProgress("Trying to retrieve email, please wait.")
                iTimeOutCnt = iTimeOutCnt + 1
                Sleep 1000
            Loop
            
            ' Check if timed out
            If iTimeOutCnt >= iTimeOut Then
                Call AddError(10)
            End If
                                    
            ' Continue if no errors
            If Me.OK Then
                             
                ' Check if path exists / cannot be created
                If Not CheckPath(sDestPath, bCreate) Then
                    Call AddError(11)
                Else
                    Call AddProgress("Saving email, please wait.")
                    
                    ' Save email
                    sDest = sDestPath & "\" & Replace(sFileName, ".msg", "", , , vbTextCompare) & ".msg"
                    oMsg.SaveAs sDest, olEmailMsg
                    
                    Call AddProgress("Emailed saved successfully.")
                    
                End If
            
            End If
            
        End If
        
    End If
    
Exit_Save_Email:

    ' Clear Outlook email objects
    Call ClearOutlook
    Exit Sub
    
Save_Email_Error:

    ' Failed to save email
    Call AddError(5, Err.Description)
    Resume Exit_Save_Email
    
End Sub

' Initialise progress window
Public Sub InitProgress(ByVal sFormName As String, ByVal sTextCtrl As String, ByVal bHide As Boolean, ByVal bClose As Boolean, Optional ByVal sSubFormName As String = "")

On Error Resume Next

    Dim cTextBox As Access.TextBox
    
    ' Open form if not open
    If Not CurrentProject.AllForms(sFormName).IsLoaded Then
        DoCmd.OpenForm sFormName, acNormal
    End If
    
    ' Hide form
    If bHide Then
        Forms(sFormName).Visible = False
    End If
    
    ' Set textbox control
    If sSubFormName <> "" Then
        Set cTextBox = Forms(sFormName).Controls(sSubFormName).Form.Controls(sTextCtrl)
    Else
        Set cTextBox = Forms(sFormName).Controls(sTextCtrl)
    End If
       
    ' Set progress vars
    oProgress.Add "Frm", sFormName
    oProgress.Add "Ctrl", cTextBox
    oProgress.Add "Close", bClose
    oProgress.Add "Hide", bHide
    
End Sub

' CLASS HELPER PRIVATE METHODS
    
' Check Outlook helper
Private Function CheckOutlook() As Boolean

On Error GoTo Outlook_Error
    
    CheckOutlook = True
    
    Dim olApp As Object
        
    ' Check outlook
    Call AddProgress("Checking Outlook is open.")
    
    Set olApp = GetObject(, "Outlook.Application")
    
    Set olApp = Nothing
    
    Exit Function
    
Outlook_Error:

    ' Outlook not open
    If Err.Number = 429 Then
        Call AddProgress("Trying to open Outlook.")
        Call Shell("Outlook.exe")
        Sleep 1000
        Resume Next
    Else
        CheckOutlook = False
        Call AddError(99, Err.Description)
    End If
    
End Function

' Add errors helper
Private Sub AddError(ByVal iErr As Integer, Optional ByVal sMsg As String = "")

    oStatus.Item("OK") = False
    oStatus.Item("Error") = iErr

    If sMsg <> "" Then
        oStatus.Item("Msg") = sMsg
    End If

End Sub

' Add progress helper
Private Sub AddProgress(ByVal sMsg As String, Optional bHide As Boolean = False)

    oProgress.Item("Msg").Add (sMsg)
    
    If bShowProgress Then
        Call ShowProgressMsg(bHide)
    End If

End Sub

' Reset status helper
Private Sub ResetStatus()

    oStatus.Item("OK") = True
    oStatus.Item("Error") = 0
    oStatus.Item("Msg") = ""
    
End Sub

' Show progress message
Private Sub ShowProgressMsg(ByVal bHide As Boolean)
    
    ' Check if form open
    If Not CurrentProject.AllForms(oProgress.Item("Frm")).IsLoaded Then
        DoCmd.OpenForm oProgress.Item("Frm"), acNormal
    End If
    
    ' Check if form visible
    If Not Forms(oProgress.Item("Frm")).Visible Then
        Forms(oProgress.Item("Frm")).Visible = True
    End If
    
    ' Update message window
    oProgress.Item("Ctrl").Value = Nz(oProgress.Item("Ctrl").Value, "") & oProgress.Item("Msg").Item(oProgress.Item("Msg").Count) & vbCrLf
    
    ' Move cursor
    oProgress.Item("Ctrl").SelStart = Len(oProgress.Item("Ctrl").Value)
    
    ' Hide message window if required
    If bHide And oProgress.Item("Hide") Then
        Forms(oProgress.Item("Frm")).Visible = False
    End If
    
    ' Ensure screen is refreshed
    DoEvents
    
End Sub

' Get draft email helper
Public Function GetEmail() As Boolean

On Error GoTo Error_GetEmail

    GetEmail = False
    
    ' Reset status
    Call ResetStatus
    
    ' Check Outlook open
    If CheckOutlook And CreateOutlook Then

        ' Get email from drafts
        Set oMsg = oApp.GetNamespace("MAPI").GetItemFromID(sDraftsID)

        ' Got email
        GetEmail = True
        
    End If
    
Exit_GetEmail:
    
    Exit Function
    
Error_GetEmail:

    If Err.Number = 440 Then
        ' Email not in drafts
        Call AddError(7)
    Else
        ' All other errors
        Call AddError(99, Err.Description)
    End If
    
    ' Clear Outlook email objects
    Call ClearOutlook
    
    Resume Exit_GetEmail
    
End Function

' Clear Outlook object helper
Private Sub ClearOutlook()

    Set oMsg = Nothing
    Set oApp = Nothing
    
End Sub

' Create Outlook helper
Private Function CreateOutlook() As Boolean

On Error GoTo Error_CreateOutlook

    CreateOutlook = True

    ' Create Outlook object
    Set oApp = CreateObject("Outlook.Application")
    
Exit_CreateOutlook:

    Exit Function
    
Error_CreateOutlook:

    CreateOutlook = False
    
    If Err.Number = 287 Then
        ' Can't open Outlook
        Call AddError(1)
    Else
        ' All other errors
        Call AddError(99, Err.Description)
    End If
    
    Resume Exit_CreateOutlook
    
End Function


' Check outbox for email
Private Function CheckOutbox() As Boolean

On Error GoTo Error_CheckOutbox

    Dim oItems As Object
    Dim bFound As Boolean
    Dim bSending As Boolean
    Dim oOutbox As Object
    Dim bSent As Boolean
    
    ' Set vars
    bFound = False
    bSending = False
    
    ' Get outlook outbox items
    If CreateOutlook Then
    
        Set oItems = oApp.GetNamespace("MAPI").GetDefaultFolder(olOutbox).Items

        ' Get first item
        Set oOutbox = oItems.GetFirst

        ' Check if matches
        bFound = (oOutbox.UserProperties.Item("EmailRef").Value = sEmailRef)

        ' Loop rest of outbox items
        Do While Not oMsg Is Nothing And Not bFound And Not bSent
            
            ' Get next item
            Set oOutbox = oItems.GetNext
            
            ' Check if matches
            bFound = (oOutbox.UserProperties.Item("EmailRef").Value = sEmailRef)
            
        Loop
        
    End If
    
Exit_CheckOutbox:
    
    Set oItems = Nothing
    Set oOutbox = Nothing
    Call ClearOutlook
    CheckOutbox = bFound Or (bSending And Not bSent)
    Exit Function
    
Error_CheckOutbox:
    
    If Err.Number = -2147221228 Then
        bSending = True
        bSent = GetSentEmail
        Resume Next
    Else
        Resume Exit_CheckOutbox
    End If
    
End Function

' Check sent items for email
Private Function GetSentEmail() As Boolean

On Error GoTo Error_GetSentEmail

    Dim oItems As Object
    Dim bFound As Boolean
    Dim iCnt As Integer
    bFound = False
    iCnt = 1
    
    ' Get outlook sent items
    If CreateOutlook Then
    
        Set oItems = oApp.GetNamespace("MAPI").GetDefaultFolder(olSentItems).Items
            
        ' Get last item
        Set oMsg = oItems.GetLast
        
        ' Check if matched
        bFound = (oMsg.UserProperties.Item("EmailRef").Value = sEmailRef)
        
        ' Loop rest of sent items based on max sent items range
        Do While Not bFound And iCnt <= iMaxSentItems And Not oMsg Is Nothing
        
            ' Get next mail item
            Set oMsg = oItems.GetPrevious
            iCnt = iCnt + 1
        
            ' Check if matches
            bFound = (oMsg.UserProperties.Item("EmailRef").Value = sEmailRef)
            
        Loop
        
    End If
       
Exit_GetSentEmail:
    
    Set oItems = Nothing
    GetSentEmail = bFound
    Exit Function
    
Error_GetSentEmail:

    Call ClearOutlook
    Resume Exit_GetSentEmail
    
End Function

' Check path helper
Private Function CheckPath(ByVal sPath As String, ByVal bCreate As Boolean) As Boolean

On Error GoTo Error_CheckPath

    Dim vDrive As Variant
    Dim vPath As Variant
    CheckPath = False
    Dim sDir As String
    Dim i As Integer
    sDir = ""

    If Len(Trim(Dir(sPath, vbDirectory))) = 0 Then
    
        If bCreate Then
        
            ' Get drive
            vDrive = Split(sPath, ":", , vbTextCompare)
        
            If UBound(vDrive) <> 1 Then
                Call AddError(12)
            Else
            
                ' Split out path
                vPath = Split(vDrive(1), "\", , vbTextCompare)
                sDir = vDrive(0) & ":"
                
                ' Loop and create
                For i = 0 To UBound(vPath)
                    sDir = sDir & vPath(i) & "\"
                    If Len(Trim(Dir(sDir, vbDirectory))) = 0 Then
                        MkDir sDir
                    End If
                Next i
                
            End If

            If Len(Trim(Dir(sPath, vbDirectory))) > 0 Then
                CheckPath = True
            End If
                
        End If
        
    Else
        CheckPath = True
    End If
    
Exit_CheckPath:

    Exit Function
    
Error_CheckPath:

    CheckPath = False
    Call AddError(99, Err.Description)
    Resume Exit_CheckPath
    
End Function 

As you can see the class been totally refactored and improved, I shall now try to explain all the options available to you.

Class Settings:

There are two class settings that can be altered depending on your requirements via accessor methods.

MaxSentItems - default 10

This is used to set the number of emails to check in the Sent Items folder to find the recently sent email, if your application sends a huge number of emails or the user might
be sending a lot of emails in conjunction with any application using this email class, you might want to increase the number.

I have included this setting as some people have a large number of emails in their Sent Items folder and you wouldn't want to check every one looking for the email just sent!

TimeOut - default 300 seconds

This is the timeout setting for how long the class keeps looking for the sent email when trying to save before it gives up.

If you have large emails with big attachments that take a while to leave the Outbox folder, you may need to increase this.

Class Attributes:

There are a few attributes that you can set values to and some that are simply for accessing information such as error messages.

Body - Get / Set the email body (can be plain text or HTML)
DraftsID - Get ID of email created in drafts - used internally but you might want to know it.
EmailRef - Get / Set a unique string identifier reference used when creating the email to be able to find it later for saving.
ErrorCode - Get latest error code.
ErrorDesc - Get latest error description (only works against in-built error codes).
OK - Boolean flag of success of last action.
ProgressMsg - This is a collection of all progress messages you can use to display your own feedback.
Sender - Get / Set Sender email address, set to empty string (default value) if to be sent from current users mail box. If you use a sender email address make sure they
have permissions to send on behalf of the email account being used as the sender email address.
ShowProgress - Set if progress messages are to be displayed - default True.
StatusMsg - Get latest status message - this contains any error message generated that doesn't match any internal error codes.

--------------------------------------------------------------------------------------------------

Class Methods:

There are a number of class methods for building the email content, as well as managing the process and saving the email.

All types of email recipient 'Add' methods are collections so multiple email addresses can be added simply by using multiple calls to the 'Add' recipient methods.
AddAttachment - Add a standard file attachment to the email (you need to include the full path as well as file name).
AddBCC - Add a 'Blind Carbon Copy' recipient email address.
AddCC - Add a 'Carbon Copy' recipient email address.
AddInline - Add an inline attachment. Takes two arguments, 1st is the file including full path, the 2nd is the file MIME type (i.e. image/gif). Remember to refer to them
in your HTML Mark-Up as 'cid:itemX' , where X = the index number of the item which is the order they were added to the collection.
AddTO - Add a standard 'TO' recipient email address.
ClearBCC - Clear the 'BCC' recipients collection.
ClearCC - Clear the 'CC' recipients collection.
ClearProgress - Clear the progress messages collection.
ClearRecips - Clear all recipients collections (TO/CC/BCC).
ClearTO - Clear the 'TO' recipients collection.
Create - Create the email saving into drafts. (Note: If you don't set the 'EmailRef' attribute you will not be able to save the email!).
Delete - Delete the current email saved in drafts.
Display - Displays the current email saved in drafts. (Use if you want to allow the user to make additional changes to the email before sending).
GetEmail - Get the current email saved in drafts. (Use to check if the email has left the drafts folder).
InitProgress - This is an important method used to set up where progress messages should be displayed to the user. There is a default call to the method in the
class_initialise subroutine, and I have included my default GUI feedback form. However, you don't have to use it and can simply use your own and it can also be in a sub-form!

There are 4 parameters as follows...

1. String - The name of the form (or parent)
2. String - The name of the textbox control on the form where the progress messages should be displayed.
3. Boolean - Set whether you want the form to be closed once email processing is finished. (If you have a generic feedback GUI control in your application and don't want it closed,
set to False!)
4. String - Optional parameter containing the name of the sub-form if using sub-forms.

I've tried to make the progress reporting functionality as flexible as possible to fit a majority of situations.

Save - Save the email to a file store (local hard drive , network share etc.). Takes 3 arguments as follows...

1. String - The path to where you want to save the email.
2. String - The name you wish to save the file as. (You can omit the .msg extension as it will be added for you!).
3. Boolean - Sets whether or not you want the folder path to be created if it doesn't exist. (Will error if the path doesn't exist or can't be created).

It's worth noting that if the email is still in drafts and you try to save the email, it will fail - so use .GetEmail to check for this!

Send - Send the current email saved in drafts.


-------------------------------------------------------------------------------------------------

OK there you have it! A brief overview of the EmailWrapperII class and all the attributes (properties) and methods.

I shall now give you a usage example and include comments to help.

CODE

Dim oEmail As New clsEmailWrapperII	'Create email wrapper object
Dim bOK as boolean ' OK flag for checking stages
bOK = True ' set to true initially    
    

oEmail.AddTO "person1@mydomain.com" ' TO Recipient

oEmail.AddCC "person2@mydomain.com" ' CC Recipient

oEmail.AddBCC "person3@mydomain.com" ' BCC Recipient

oEmail.Subject = "This is an email subject" ' Email Subject

oEmail.Body = "<html><head></head><body<h1>This is the email body heading text</h1><p>This is some email body paragraph text</p><img src="cdi:item1" alt="An Inline Image" />
</body></html>" ' Email Body

oEmail.AddAttachment "c:\my_path\my_file.ext" ' Standard Email Attachment

oEmail.AddInline "c:\my_path\my_file.gif", "image/gif" ' Inline Email Attachment

oEmail.EmailRef = "Some text for email reference - " & DateDiff("s", #1/1/1970#, Now()) ' Unique Email Reference for saving email - I tend to add the EPOCH date on the end to 
ensure it is always unique

oEmail.Create ' create the email into drafts

       
' check email created ok
        
If oEmail.OK Then

    ' display email
    oEmail.Display
    
    ' so far so good - check ok and save email
    If vbNo = MsgBox("Are you happy with the email?" & vbCrLf & vbCrLf & "Selecting 'No' will delete the email.", vbYesNo) Then
    
        ' delete email
        oEmail.Delete
        If Not oEmail.OK Then
            MsgBox oEmail.ErrorDesc
        End If
        
    Else       
        
        ' try to save email - creating folder path if doesn't exist
        oEmail.Save "C:\My_Path\Email_Folder", "Name_Of_File", True
        
        ' check save OK
        If Not oEmail.OK Then
        
            ' check error code for unsent email
            If oEmail.ErrorCode = 9 Then ' Email is still in drafts.
            
                If vbYes = MsgBox("You didn't send the email, do you wish to send it now?" & vbCrLf & vbCrLf & "Selecting 'No' will delete the email.", vbYesNo) Then
                                                
                    ' try to send email for them
                    oEmail.Send
                    
                    ' allow email to send
                    Do While oEmail.GetEmail
                        DoEvents
                        Sleep 3000
                    Loop
                    
                    ' try to save email again  - creating folder path if doesn't exist
                    oEmail.Save "C:\My_Path\Emails_Folder", "Name_Of_File", True
                        
                    ' check if send OK                            
                    If Not oEmail.OK Then   
                        bOK = False
                    End If                                              
                    
                Else
                
                    ' delete email
                    oEmail.Delete
                    bOK = False
                    
                End If
                
            Else
                bOK = False
            End If
            
        End If
        
        ' check if saved ok 
        If bOK And oEmail.OK Then
            
            MsgBox "Email has been sent / saved successfully."
            
        Else
        
            ' show erorr and delete email
            If Not oEmail.OK Then
                MsgBox oEmail.ErrorDesc
            End If
            oEmail.Delete
            
        End If
        
    End If
        
Else
    MsgBox oEmail.ErrorDesc
End If

Set oEmail = nothing 

You may notice this loop code...

CODE

' allow email to send
Do While oEmail.GetEmail
    DoEvents
    Sleep 3000
Loop     

I have found while in production that if a user forgets to send the email, and you try to save the email and the class notices the email is still in drafts and so you ask the
user if they would like to send the email.

If the email is quite large or has many large attachments, there is likely to be a delay between the email leaving the Drafts folder and entering the Outbox folder.

It seems instantly calling .Save after a .Send tends to fail in this situation, therefore you may need to have code that gives Outlook enough time to process the .Send request
before trying to execute the .Save method.

OK it's a bit of sledgehammer approach as the loop continues forever until the email has left the Drafts folder, just in case there is a problem sending the email to the Outbox,
maybe you might want to have a counter with a timeout and error handling to the user, but so far (touch wood), this approach has worked for us fine without any issues!

I hope you find the new EmailWrapperII class useful, and welcome all feedback.

Use link below to download ZIP file containing the progress information GUI form and clsEmailWrapperII.cls class file.

Download EmailWrapperII Source Code

Have fun and happy emailing smile

1DMF.

Back to Microsoft: Access Modules (VBA Coding) FAQ Index
Back to Microsoft: Access Modules (VBA Coding) Forum

My Archive

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close