Filing Sent Items

Hello,

We currently have a macro on our Outlook here at work that prompts the user to select a folder to save a sent item in a selected folder each time they click send. I didn't write this code and i have to confess that I know nothing about VBA in Outlook (I'm more of an Excel man).

I have been asked to see if I can change the macro so that as well as saving the sent item in the selected folder, a copy is also placed in the sent items folder so that people can easily view a list of all items sent.

Can anyone please tell me what needs to be added to this code in order to achieve this:

Code:

---

Dim WithEvents colSentItems As Items

Private Sub Application_Startup()

    Dim ns As Outlook.NameSpace
   
    Set ns = Application.GetNamespace("MAPI")
 
'  Set event handler on the sent items folder to monitor when new items are saved to the folder
    Set colSentItems = ns.GetDefaultFolder(olFolderSentMail).Items
 
    Set ns = Nothing
   
End Sub

Private Sub colSentItems_ItemAdd(ByVal Item As Object)

    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder

'  This is fired every time an item is added to the Sent Items Folder
    If Item.Class = olMail Then
   
'  Only do this if the item is a sent email, ignore meeting requests etc.
    Set objNS = Application.GetNamespace("MAPI")
    Set objFolder = objNS.PickFolder
        Do While objFolder Is Nothing
            Set objFolder = objNS.PickFolder
        Loop
    If TypeName(objFolder) = "MAPIFolder" Then
            If Not objFolder = objNS.GetDefaultFolder(olFolderSentMail) Then
'              move email to the selected folder
                Item.Move objFolder
            End If
    End If
       
    Set objFolder = Nothing
    Set objNS = Nothing
       
    End If

End Sub

---

Thanks

If you want to leave a copy in the Sent Items folder, then you need to create a copy of the message and move that to the selected folder:

Code:

---

Option Explicit

Private WithEvents colSentItems As Items
 
Private Sub Application_Startup()
    Dim ns As Outlook.NameSpace
    Set ns = Application.GetNamespace("MAPI")
    '  Set event handler on the sent items folder to monitor when new items are saved to the folder
    Set colSentItems = ns.GetDefaultFolder(olFolderSentMail).Items
    Set ns = Nothing
End Sub

Private Sub colSentItems_ItemAdd(ByVal Item As Object)

Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim oCopiedItem As MailItem

    '  This is fired every time an item is added to the Sent Items Folder
    If Item.Class = olMail Then
        Set oCopiedItem = Item.Copy

        '  Only do this if the item is a sent email, ignore meeting requests etc.
        Set objNS = Application.GetNamespace("MAPI")
        Do While objFolder Is Nothing
            Set objFolder = objNS.PickFolder
        Loop
        If TypeName(objFolder) = "MAPIFolder" Then
            If Not objFolder = objNS.GetDefaultFolder(olFolderSentMail) Then
                '              move email to the selected folder
                oCopiedItem.Move objFolder
            End If
        End If
        Set objFolder = Nothing
        Set objNS = Nothing
    End If
End Sub

---

Works perfectly. Thanks gpmayor

You could just create a search folder that searches for messages sent by the user and add that to the favorites in place of the standard 'sent items' folder. I think that has the advantage of avoiding creating duplicate copies of the mails, so it will keep your PST file size down

I have 2 email accounts (actually 3 if you count my gmail). This only works for 1 of my outlook accounts. How can I get this to work with the other outlook account (and gmail if possible).

Quote:

---

Originally Posted by gmayor

If you want to leave a copy in the Sent Items folder, then you need to create a copy of the message and move that to the selected folder:

Code:

---

Option Explicit

Private WithEvents colSentItems As Items
 
Private Sub Application_Startup()
    Dim ns As Outlook.NameSpace
    Set ns = Application.GetNamespace("MAPI")
    '  Set event handler on the sent items folder to monitor when new items are saved to the folder
    Set colSentItems = ns.GetDefaultFolder(olFolderSentMail).Items
    Set ns = Nothing
End Sub

Private Sub colSentItems_ItemAdd(ByVal Item As Object)

Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim oCopiedItem As MailItem

    '  This is fired every time an item is added to the Sent Items Folder
    If Item.Class = olMail Then
        Set oCopiedItem = Item.Copy

        '  Only do this if the item is a sent email, ignore meeting requests etc.
        Set objNS = Application.GetNamespace("MAPI")
        Do While objFolder Is Nothing
            Set objFolder = objNS.PickFolder
        Loop
        If TypeName(objFolder) = "MAPIFolder" Then
            If Not objFolder = objNS.GetDefaultFolder(olFolderSentMail) Then
                '              move email to the selected folder
                oCopiedItem.Move objFolder
            End If
        End If
        Set objFolder = Nothing
        Set objNS = Nothing
    End If
End Sub

---

---