Consulting

Results 1 to 3 of 3

Thread: Delete Just Sent Mail from Sent Items Folder

  1. #1
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    2,960
    Location

    Delete Just Sent Mail from Sent Items Folder

    Hi,

    I'm attempting to use the following code to send an email using OUTLOOK from Word. The code runs without error, but the e-mail is apparently not sent (not received on other end).

    If if remove this line:
    oMailItem.DeleteAfterSubmit = True

    The mail is sent (received) but remains in the sent items folder.

    How can I send an email and then immediately remove it from the sent items folder.

    Thanks

    Option Explicit
    Const olMinimized As Long = 1
    Const olMaximized As Long = 2
    Const olFolderInbox As Long = 6
    
    Sub SendBillingLogToSam(bWAttachment As Boolean, Optional strAttachmentPath As String)
    Dim oOutlookApp As Object, oNS As Object, oInsp As Object
    Dim oFolder As Object, oMailItem As Object
    Dim lngState As Long
        
      lngState = Application.WindowState
      Application.WindowState = wdWindowStateMinimize
      Application.ScreenUpdating = False
      Set oOutlookApp = OutlookApp()
      Set oNS = oOutlookApp.GetNamespace("MAPI")
      Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
      'Create a new message
      Set oMailItem = oOutlookApp.CreateItem(0) 'olMailItem
      With oMailItem
        .To = "sam@jonesfirm.com"
        .Subject = "TEST TEST TEST Past Billing Log with Auto Delete from Sent Items Folder TEST TEST TEST"
        If bWAttachment Then
          .Attachments.Add strAttachmentPath
          .Body = "Sam, " & vbCr + vbCr & "Here is the latest billing log on file."
        Else
          .Body = "Sam," & vbCr + vbCr & "There was no past billing log found on file."
        End If
        oMailItem.Sent
      End With
      oMailItem.DeleteAfterSubmit = True
      Application.WindowState = lngState
      Application.ScreenUpdating = True
    lbl_Exit:
      Set oOutlookApp = Nothing: Set oNS = Nothing
      Set oFolder = Nothing
      Set oMailItem = Nothing
    End Sub
    
    
    Public Function OutlookApp(Optional WindowState As Long = olMinimized, _
                               Optional ReleaseIt As Boolean = False) As Object
    Static oApp As Object
      On Error GoTo ErrHandler
      Select Case True
        Case oApp Is Nothing, Len(oApp.Name) = 0
          Set oApp = GetObject(, "Outlook.Application")
          If oApp.Explorers.Count = 0 Then
    InitOutlook:
            'Open inbox to prevent errors with security prompts
            oApp.Session.GetDefaultFolder(olFolderInbox).Display
            oApp.ActiveExplorer.WindowState = WindowState
          End If
          Case ReleaseIt: Set oApp = Nothing
      End Select
      Set OutlookApp = oApp
    ExitProc:
      Exit Function
    ErrHandler:
      Select Case Err.Number
        Case -2147352567
          'User cancelled setup, silently exit
          Set oApp = Nothing
        Case 429, 462
          Set oApp = GetOutlookApp()
          If oApp Is Nothing Then
            Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
          Else
            Resume InitOutlook
          End If
        Case Else: MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
      End Select
      Resume ExitProc
      Resume
    End Function
    
    
    Private Function GetOutlookApp() As Object
      On Error GoTo ErrHandler
      Set GetOutlookApp = CreateObject("Outlook.Application")
    ExitProc:
      Exit Function
    ErrHandler:
      Set GetOutlookApp = Nothing
      Resume ExitProc
      Resume
    End Function
    Greg

    Visit my website: http://gregmaxey.com

  2. #2
    VBAX Mentor Logit's Avatar
    Joined
    Sep 2016
    Posts
    421
    Location
    .
    "Immediately delete from the Sent Folder" ... is what your code is presently doing. However, it would appear the code at present
    is somehow deleting the email before it gets sent ... even though it shouldn't. This observation is based on your comments of
    what is presently occurring.

    You could attempt to include a delay in your code, just prior to deleting the email from the Sent Folder. Perhaps give it 5 seconds ?
    Hopefully that will give your system and Outlook to send the email first.

    Just a thought.

  3. #3
    The following works as intended here (I have Outlook configured not to send immediately). The message is delivered to the outbox and removed from the sent items folder (when you send it). I have sent you the example message from the code, so if you get it, it will confirm that it works.

    Note that the line should be oMailItem.Send not oMailItem.Sent and you should set the deleteaftersubmit option before you send it.

    As you have set a variable to oInsp you should use it to format your message as that will also keep your signature. oFolder is superfluous


    Sub Test()
    SendBillingLogToSam False
    End Sub
    
    
    
    
    Sub SendBillingLogToSam(bWAttachment As Boolean, Optional strAttachmentPath As String)
    Dim oOutlookApp As Object, oNS As Object, oInsp As Object
    Dim oFolder As Object, oMailItem As Object
    Dim lngState As Long
    Dim wdDoc As Document
    Dim oRng As Range
    
    
        lngState = Application.WindowState
        Application.WindowState = wdWindowStateMinimize
        Application.ScreenUpdating = False
        Set oOutlookApp = OutlookApp()
        Set oNS = oOutlookApp.GetNamespace("MAPI")
        Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
        'Create a new message
        Set oMailItem = oOutlookApp.CreateItem(0)    'MailItem
        With oMailItem
            Set oInsp = .GetInspector
            Set wdDoc = oInsp.WordEditor
            Set oRng = wdDoc.Range
            oRng.Collapse 1
            .Display 'required
            .DeleteAfterSubmit = True
            .To = "sam@jonesfirm.com"
            .Subject = "TEST TEST TEST Past Billing Log with Auto Delete from Sent Items Folder TEST TEST TEST"
            If bWAttachment Then
                .Attachments.Add strAttachmentPath
                oRng.Text = "Sam, " & vbCr + vbCr & "Here is the latest billing log on file."
            Else
                oRng.Text = "Sam," & vbCr + vbCr & "There was no past billing log found on file."
            End If
            oMailItem.Send
        End With
        Application.WindowState = lngState
        Application.ScreenUpdating = True
    lbl_Exit:
        Set oOutlookApp = Nothing: Set oNS = Nothing
        Set oFolder = Nothing
        Set oMailItem = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •