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