How do I Email via Microsoft Outlook and save sent .msg Email file to a specific location.

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

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
                    
                   [b] ' allow email to send
                    Do While oEmail.GetEmail
                        DoEvents
                        Sleep 3000
                    Loop[/b]
                    
                    ' 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

[b]' allow email to send
Do While oEmail.GetEmail
    DoEvents
    Sleep 3000
Loop    [/b]