VBA to identify a specific email and copy the attachment from it to the network

[The_Snook]

Hi,

I've created a scheduler in our Cognos reporting system that emails me an updated data extract each morning. What I would like is a macro that identifies this daily email (perhaps when I open outlook?) and copies the attachment to a defined area on the network. If it helps the email address, subject name and attachment name are always the same. For the purposes of this let's say they are as follows:

Email - Snook@hotmail.com
Subject - Cognos Data Extract
Attachment - Data Extract.xlsx
Network Address - \\network\performance management

What would also be useful is if the email could be moved to another folder within my inbox once the attachment has been extracted, e.g. named 'Cognos'.

If you require any further info just give me a shout.

Thanks in advance,

Snook

[Gregor y]

I sugest that you create a rule to move the emails into the 'Cognos' folder then set a ribbon button for the following macro that you can run while viewing the 'Cognos' folder. That way you wouldn't need to update the code if your email selection criteria changes you'd just update the outlook rule.

Public Sub ExportAttachments()
    'I'm not sure if a UNC path will work you may need to map a network drive
    Const pth As String = "\\network\performance management\"
    Dim fldr As MAPIFolder, itm As Object, em As MailItem, a As Attachment
    'I just took a guess with 'Mailbox - Snook', it'll be whatever the name of the "Data File" is
    '   it should be the root folder for your Inbox
    'Set fldr = Application.GetNamespace("MAPI").Folders("Mailbox - Snook").Folders("Cognos")
    'For Each itm In fldr.Items
    For Each itm In ActiveExplorer.CurrentFolder
    If itm.Class = olMail Then
        Set em = itm
    If em.Importance <> olImportanceLow Then
        For Each a In em.Attachments
            a.SaveAsFile pth & Format(em.SentOn, "yymmddhhmm") & " " & a.FileName
        Next a
        em.Importance = olImportanceLow
        em.Save
    End If: End If
    Next itm
End Sub