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