Solved: Saving Sent Mail to an Alternate Folder

[Opv]

Is there a simple way when generating email from within Excel to cause the sent mail to be saved in a folder other than the "Sent Items" folder? I'd actually like to have the items automaticlaly moved to the "Deleted Items" folder.

[Opv]

P.S. I'm using Outlook 2000 and Excel 2000.

[mdmackillop]

You can create Rules in outlook to do such tasks. Have you checked these out?

[Opv]

Yes, I tried creating a Rule; however, unless I am missing something, that options does not appear to be working with my email being gnenrated from Excel. Here is the Excel code I'm using:

[VBA]
Sub TestFile()
'Authored by Ron de Bruin
'SOURCE: http://www.rondebruin.nl/mail/folder3/message.htm
'Copied Saturday, March 12, 2011
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then

Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
''''' ADDED BY Opv '''''
'.DeleteAfterSubmit = True
''''' END ADDED BY Opv '''''
.To = cell.Value
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'Or use Display

End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
[/VBA]

This code generates individual personalized emails from a specified range of cells. I figured out how to automatically prevent the sent messages from showing up in my "Sent Items" folder. However, I'd rather have the email show up in the "Deleted Items" folder than not show up at all. I can't seem to figure out how to modify the code to make that happen.

Thanks,

Opv

[mdmackillop]

Code reordered to move object setting outside loop
[VBA]Option Explicit

Sub TestFile()
'Authored by Ron de Bruin
'SOURCE: http://www.rondebruin.nl/mail/folder3/message.htm
'Copied Saturday, March 12, 2011
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim myNameSpace As Object
Dim mySent As Object
Dim myDestFolder As Object

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

Set myNameSpace = OutApp.GetNamespace("MAPI")
Set mySent = myNameSpace.GetDefaultFolder(5) '"Sent Items"
Set myDestFolder = myNameSpace.GetDefaultFolder(3) '"Deleted Items"

On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then

Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
''''' ADDED BY Opv '''''
'.DeleteAfterSubmit = True
''''' END ADDED BY Opv '''''
.To = cell.Value
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.send 'Or use Display
'Move Sent item to Deleted Items folder
mySent.items(mySent.items.Count).Move myDestFolder
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
[/VBA]

[Opv]

Thanks. Somehow that code is moving the wrong emails from the Sent Items folder. It is moving the correct number of emails but it removing the most recent previously sent emails and leaving the items that should be deleted.

I initially was wondering if there was a way to incorporate the .SaveSentMessageFolder property and just define where the sent messages were to be stored rather than having to move them.

[mdmackillop]

I thought there was a possibility of that!
You could try looking for the subject or the last sent item. I've added a delay to allow the mail item to arrive in the Sent Items folder. You could try adjusting this.
[VBA].send 'Or use Display

Application.Wait (Now + TimeValue("0:00:05"))


'Finding subject
Set MyItems = mySent.items
Set MyItem = MyItems.Find("[Subject] = 'Reminder'")
If Not MyItem Is Nothing Then

MyItem.Move myDestFolder

Else

'Finding last
Dim i, t
Set MyItems = mySent.items
TimeStamp = 0
For Each i In MyItems
t = i.SentOn
If t > TimeStamp Then
TimeStamp = t
Set MyItem = i
End If
Next
MyItem.Move myDestFolder

End If[/VBA]

[Opv]

I seem to have got it to work (by pure happenstance) by adding the following line of code:

[VBA]
Set .SaveSentMessageFolder = myDestFolder
[/VBA]

and disabling (commenting out) the move statement.

[mdmackillop]

Good find. I would clean it up to
[VBA] Set myNameSpace = OutApp.GetNamespace("MAPI")
Set myDestFolder = myNameSpace.GetDefaultFolder(3) '"Deleted Items"

On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then

Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail

Set .SaveSentMessageFolder = myDestFolder

.To = cell.Value
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
[/VBA]

[Opv]

Thanks for your help. I think I can mark this project solved.

Opv