Save Sent Message To....

[jbeaucaire]

I'm using a standard little Excel macro to send an individual email to each person in a list:

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With ActiveSheet
    For Each Email In .Range("T2:T70")
        With OutMail
            .To = Email
            .CC = ""
            .BCC = ""
            .Subject = .Range("A" & Email.Row) & " - Computer Updated"
            .Body = "Message text here"
            .Display   'or use .Send
            '.send
        End With
    Next Email
End With

Problem, I'd like to set the "Save Sent Message To:" option on each of these emails, too. Is there a way to do this in Excel VBA? I could just copy all these emails manually out of the SENT EMAILS folder, but if it's possible to file them using the macro, even better.

 

[jbeaucaire]

Also posted here....

 

[jbeaucaire]

This was resolved in the other thread. The use of the .CreateItemFromTemplate method allows me to use a template that already has the correct Save To folder setup in the template's options, it also as the added benefit of inserting my Signature, too.

The Final code:

Option Explicit

Sub EmailUpdates()
Dim OutApp  As Object
Dim OutMail As Object
Dim Emails  As Range
Dim Email   As Range
Dim Subject As String

If MsgBox("Process the Activesheet?", vbYesNo, "Proceed?") = vbNo Then Exit Sub

With ActiveSheet
    Set Emails = .Range("T2", .Range("T" & .Rows.Count).End(xlUp)).SpecialCells(xlFormulas, 2)
    Set OutApp = CreateObject("Outlook.Application")
    
    For Each Email In Emails
        Set OutMail = OutApp.CreateItemFromTemplate("C:\Documents and Settings\Jerry\Application Data\Microsoft\Templates\Monetra Upgrade Completed - VP2.oft")
        Subject = Email.Offset(, -19) & " - Monetra Updated"
        With OutMail
            .To = Email.Text
            .Subject = Subject
            .Display
            '.Send
        End With
        Email.Offset(, -1) = "Done"
    Next Email
End With

End Sub