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
Code:
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