vbaemailoutlookmailmessagemailitem

Delete draft mail on close when not sent


I've got some draft mails with some buttons to copy and open them. Only a few values need to be filled in and then the mails will be sent. I want to keep the drafts. But if a mail is not sent, I would like to delete it because it is a copy. I'm working with the close event for a mail item, but I can't seem to find out how to delete it in that sub, tried many things. Anyone knows how to approach this?

Code I got so far in a module:

Dim itmevt As New CMailItemEvents
Public olMail As Variant
Public olApp As Outlook.Application
Public olNs As NameSpace
Public Fldr As MAPIFolder


Sub TeamcenterWEBAccount()

Dim i As Integer
Dim olMail As Outlook.MailItem

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderDrafts)

For Each olMail In Fldr.Items
    If InStr(olMail.Subject, "New account") <> 0 Then
        Set NewItem = olMail.Copy
        olMail.Display
        Set itmevt.itm = olMail
        Exit Sub
    End If
Next olMail

End Sub

Code in the CMailItemEvents class module:

Option Explicit
Public WithEvents itm As Outlook.MailItem

Private Sub itm_Close(Cancel As Boolean)
    Dim blnSent As Boolean
    On Error Resume Next
    blnSent = itm.Sent
    If blnSent = False Then
        itm.DeleteAfterSubmit = True
    Else
       ' do
End Sub

Solution

  • Please, try the next way:

    1. Copy the next adapted code (instead of your code, or in a new standard module):
    Option Explicit
    
    Private itmevt As New CMailItemEvents
    Public deleteFromDrafts As Boolean, boolContinue As Boolean
    
    Sub TeamcenterWEBAccount()
     Dim olMail As Outlook.MailItem, NewItem As Outlook.MailItem, boolDisplay As Boolean
     Dim olApp As Outlook.Application, Fldr As MAPIFolder, olNs As NameSpace
    
     Set olApp = New Outlook.Application
     Set olNs = olApp.GetNamespace("MAPI")
     Set Fldr = olNs.GetDefaultFolder(olFolderDrafts)
    
     For Each olMail In Fldr.Items
        If InStr(olMail.Subject, "New account") > 0 Then
           On Error Resume Next  'for the case of inline response
           Set NewItem = olMail.Copy
           If Err.Number = -2147467259 Then
                Err.Clear: On Error GoTo 0
                olMail.Display: boolDisplay = True
                For i = 1 To 1000: DoEvents: Next i 'just wait for the window to be displayed...
                Set NewItem = olMail.Copy
           End If
           On Error GoTo 0
            deleteFromDrafts = False: boolContinue = False 'initialize the boolean variables to wait for them in the loop
            If Not boolDisplay Then olMail.Display
            Set itmevt.itm = olMail
            
            'wait for close event to be triggered...
            Do While deleteFromDrafts = False And boolContinue = False
                    DoEvents
            Loop
            
            If deleteFromDrafts Then
                    If Not olMail Is Nothing Then olMail.Delete 'let only the copy...
            End If
            Exit Sub
        End If
     Next olMail
    End Sub
    
    1. Copy the next adapted code to replace the existing one in the used class:
    Option Explicit
    
    Public WithEvents itm As Outlook.MailItem
    
    Private Sub itm_Close(Cancel As Boolean)
        Dim blnSent As Boolean
        
        On Error GoTo Ending 'for the case of mail sending, when itm looses its reference...
            If blnSent = False Then
                itm.DeleteAfterSubmit = True
                deleteFromDrafts = True
            Else
               boolContinue = True
            End If
            Exit Sub
    Ending:
        boolContinue = True
    End Sub
    

    Tested, but not intensively...

    Please, send some feedback after testing it in your specific environment.