Move Sent Mail Items from Sent Items to a shared folder 1

[PeterStevens]

Hi, I'm having trouble with a VBA solution to my problem. Basically I've written an excel spreadsheet that creates 109 files which need to be sent to about 30 people individually. I've written the code to create and attach the files to the emails but my Mailbox size at work is a measley 10MB and gets filled up after the firt few have been sent.

My question is: Is it possible to move a specific email from my sent items folder into a personal folder so I can keep a record of what I have sent to who and when? Ideally I'd like to do this in the loop that sends the mail as soon as its been sent so I don't fill my Mailbox while the macro is running. I've posted my code so far below for explanation. Any suggestions would be really welcome!! Thanks.

Dim MyOlApp As Object
Dim MyMail As Variant
Dim emcllobj As Range
Dim CCRows As Integer
Dim MailAddress As String
Dim Attachments() As String
Dim NumAttachments As Integer

    CCRows = ThisWorkbook.Worksheets("Email Address").Range("A65000").End(xlUp).Row
    
    For Each emcllobj In ThisWorkbook.Worksheets("Email Address").Range("A2:A" & CCRows)
        
        MailAddress = emcllobj.Offset(0, 1).Value
        
    
'1. construct email
        
        Set MyOlApp = CreateObject("Outlook.Application")   'Create outlook
        Set MyMail = MyOlApp.CreateItem(olMailItem)         'create mail item
        
        With MyMail
            .Recipients.Add (MailAddress)
            .Subject = "Data Pack -  " & emcllobj
            .htmlbody = "" 'Insert EMail Body Text Here
            
        End With
        
'2. Add Data Packs & Forms to MyMail message
        
        'count number of cost centres to attach
        If Range(emcllobj.Offset(0, 4), emcllobj.Offset(0, 4).End(xlToRight)).Cells.Count = 252 Then
            NumAttachments = 1
        Else
            NumAttachments = Range(emcllobj.Offset(0, 4), emcllobj.Offset(0, 4).End(xlToRight)).Cells.Count
        End If
        
        'add data packs to MyMail
        For i = 1 To NumAttachments
            MyMail.Attachments.Add (ThisWorkbook.Path + "\" & emcllobj.Offset(0, 3 + i).Value & ".xls")
        Next i
                
'3. Send Email Message and Move to Data Pack Sent Folder
    
        MyMail.Send
 
       **Move sent email to personal folder**

        Set MyOlApp = Nothing   'release variable
        Set MyMail = Nothing    'releas variable
        
    Next emcllobj

 

[HarleyQuinn]

You might want to have a look at the SaveSentMessageFolder property.

Hope this helps

HarleyQuinn
---------------------------------
Black coat, white shoes, black hat, cadillac. The boy's a timebomb!

You can hang outside in the sun all day tossing a ball around, or you can sit at your computer and do something that matters. - Eric Cartman

Get the most out of Tek-Tips, read FAQ222-2244: How to get the best answers before post