Outlook 2007 - Extracting attachments from .msg

[alan87]

Hi, I receive alot of emails which include .msg attachments. I usually have to manually open the email, then open the .msg attachment to get to the .pdf file which is attached. I often receive over 200 emails in this format and it takes some time to get all the PDF files printed. I managed to put together the below code (With a lot of help from the online forums). But i'm struggling on a few things and wondered if anyone can help:

1) I need to amend the code so it takes into consideration the .pdf files which have the same name, i.e. AT00001. Ideally if the code could add a number to the beggining of each file AT00001, 1-AT00001, 2-AT00001 etc
2) The code is currently pulling all attachments from within the .msg file, I only need the PDF files

  Sub SaveOlAttachments()

    Dim olFolder As Outlook.MAPIFolder
    Dim msg As Outlook.MailItem
    Dim msg2 As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim strFilePath As String
    Dim strTmpMsg As String
    Dim fsSaveFolder As String

    fsSaveFolder = "C:\Users\nicholson.a.9\Desktop\Invoices to Print\"

 
    strFilePath = "C:\temp\"
    strTmpMsg = "KillMe.msg"

    Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set olFolder = olFolder.Folders("MSG Attachments")
    If olFolder Is Nothing Then Exit Sub

    For Each msg In olFolder.Items
        If msg.Attachments.Count > 0 Then
        While msg.Attachments.Count > 0
        bflag = False
            If Right$(msg.Attachments(1).FileName, 3) = "msg" Then
                bflag = True
                msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
                Set msg2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
            End If
            If bflag Then
                sSavePathFS = fsSaveFolder & msg2.Attachments(1).FileName
                msg2.Attachments(1).SaveAsFile sSavePathFS
                msg2.Delete
            Else
                sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
                msg.Attachments(1).SaveAsFile sSavePathFS
            End If
            msg.Attachments(1).Delete
            Wend
             msg.Delete
        End If
    Next
    End Sub

I would be hugely grateful if anyone can help
Thanks

[alan87]

I've managed to fix my first problem with the below code:

i = i + 1
                sSavePathFS = fsSaveFolder & "\" & i & " - " & msg2.Attachments(1).FileName

It now lists a number in front of each attachment it extracts i.e 1-AT0001, 2-AT0001, 3-AT0001 etc.
It's still extracting everything that is attached to the email though, I only need the PDF's. Any ideas?

[westconn1]

If Right$(msg.Attachments(1).FileName, 3) = "msg" Then

this line should check if the file extension of each attachment is msg, which does not appear to be what you want, your code seems to processes each attachment, making a copy if the message if the attachment is "msg", though apparently this must not work correctly as all attachments are being opened
you should do something like

If msg.Attachments.Count > 0 Then
    For Each a In msg.Attachments
        If LCase(Right(a.FileName, 3)) = "pdf" Then 
           a.SaveAsFile sSavePathFS
        else
             'remove delete or whatever
        end if
    Next

if you want to automatically print the pdf, use shellexecute API with the print verb, to use the default installed program to print the file

[alan87]

Thanks a bunch for this, its working perfect now
Do you know how I could amend the script so it doesnt delete the original email?

Im sure its something to do with the last part of the script

msg.Attachments(1).Delete
Wend
msg.Delete
End If
Next
End Sub

I would like it to strip the attachments and leave the original email in the same folder rather than moving it to deleted items

Again thanks for your help, much appreciated.

[westconn1]

msg.delete would delete the original message, i guess removing that line should stop the email from deleting

[alan87]

Thanks for getting back to me, when I remove msg.delete, the code is then deleting the attachments from my original email and saving it that way, is there anyway to stop this?
I tried to also remove msg.attachment(1).delete however the code then only removes the first attachment of each email

[westconn1]

i am not sure i understand what is the current problem, is it deleting some attachments you want or not deleting some?
please post the updated complete code, use code tags to make the code more readable

[alan87]

This is the completed code that I have at the moment:

Sub SaveOlAttachments()

    Dim olFolder As Outlook.MAPIFolder
    Dim msg As Outlook.MailItem
    Dim msg2 As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim strFilePath As String
    Dim strTmpMsg As String
    Dim fsSaveFolder As String

    fsSaveFolder = "C:\Users\nicholson.a.9\Desktop\Invoices to Print\"

    strFilePath = "C:\temp\"
    strTmpMsg = "KillMe.msg"

    Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set olFolder = olFolder.Folders("MSG Attachments")
    i = 0
    If olFolder Is Nothing Then Exit Sub

    For Each msg In olFolder.Items
        If msg.Attachments.Count > 0 Then
        While msg.Attachments.Count > 0
        bflag = False
            If Right$(msg.Attachments(1).FileName, 3) = "msg" Then
                bflag = True
                msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
                Set msg2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
            End If
            If bflag Then
            i = i + 1
                sSavePathFS = fsSaveFolder & "\" & i & " - " & msg2.Attachments(1).FileName
                msg2.Attachments(1).SaveAsFile sSavePathFS
                msg2.Delete
            Else
                sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
                msg.Attachments(1).SaveAsFile sSavePathFS
            End If
            msg.Attachments(1).Delete
            Wend
            msg.delete
        End If
    Next
    End Sub

The code is working fine, i.e. I place an email which has a .msg file into a sub folder called MSG Attachments, I then run the above code and it extracts the attachments from the .MSG file into a folder on my desktop. This works perfectly.

I am looking to change 1 thing, after the above code has run, I would like the original email (That is located in MSG Attachment folder) to either be marked as Read or moved into a different folder i.e. MSG Attachments READ. (At the moment, the code is deleting the email after executing the above code)

If I delete

msg.delete

the code still extracts the attachments into the folder on my desktop, however the original email (That is located in MSG Attachment folder) is saved without any attachments. i.e as if they have been deleted

Hopefully this is a bit more clear, thanks a bunch for your help on this