Unpacking a message with message attachments

Hello,

I have a macro (I tried to post it here, but it keeps saying "Post denied" for some reason - no URLs whatsoever or forbidden words) which identifies Outlook messages which contain PDF attachments and prints/copies them onto a folder in my desktop. Problem: It doesn't recognise messages which have other messages as attachments. It ignores these. I want my macro to be able, in plain English to:

For each message in selected folder...
For each attachment in this message
Is this attachment a PDF?
If so, PRINT AND COPY
If not, is this attachment a message?
If yes, For each attachment in this message
Is this attachment a PDF?
If so, PRINT AND COPY
End
Next attachment
End
End
End
Next
Next

Does that make sense? I have all the code I need apart from interrogating messages as attachments.

Thanks

This demonstrates how to process an attached mailitem.

Code:

---

Sub msgAsAttachment()

Dim curritem As MailItem
Dim att As attachment
Dim msgInternal As MailItem
Dim attInternal As attachment
Dim tempFileName As String
Dim tempFolder As String

tempFolder = "C:\Test\" ' be careful to end with a slash
tempFileName = "dummy.msg"

Set curritem = ActiveInspector.currentItem

For Each att In curritem.Attachments

    Debug.Print att.FileName
   
    If Right(att.FileName, 3) = "msg" Then
       
        att.SaveAsFile tempFolder & tempFileName
        Set msgInternal = CreateItemFromTemplate(tempFolder & tempFileName)
        For Each attInternal In msgInternal.Attachments
            Debug.Print attInternal.FileName
        Next
        msgInternal.Delete

    End If
   
Next

Set msgInternal = Nothing
Set curritem = Nothing

End Sub

---

Thanks so much for your reply, skatonni. I thought the solution would involve copying the message with attached messages somewhere temporarily. I'm guessing CreateItemFromTemplate converts an object external to Outlook into an Outlook object?

Hi, just stepped through the code and it does the job, explains the process which is all that I need. What does this line do:

Code:

---

msgInternal.Delete

---

I expected it to delete the temporary file in C:\Test\, but it didn't do that, or delete the message in the Inbox. What does it delete?

msgInternal.Delete is deleting the open message from Outlook. The following version will remove the temporary file also.

Based on skattoni's process for handling attached messages, the following should print the PDFs, though what you mean by 'copy' them I am not sure. It saves them in the named folder. The code does not include any error handling for PDFs of the same name:

Code:

---

Option Explicit
Sub PrintPDFs()
Dim olFolder As Folder
Dim olItem As MailItem
    Set olFolder = Application.Session.PickFolder
    For Each olItem In olFolder.Items
        msgAsAttachment olItem
    Next olItem
lbl_Exit:
    Set olFolder = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

Sub msgAsAttachment(olItem As MailItem)
Dim att As Attachment
Dim sFname As String, sIntFname As String
Dim sExt As String
Dim msgInternal As MailItem
Dim attInternal As Attachment
Const pdfApp As String = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe"
Const tempFileName As String = "dummy.msg"
Const tempFolder As String = "C:\Test\"
    For Each att In olItem.Attachments
        sFname = att.FileName
        sExt = Mid(sFname, InStrRev(sFname, Chr(46)))
        Select Case sExt
            Case ".msg"
                att.SaveAsFile tempFolder & tempFileName
                Set msgInternal = CreateItemFromTemplate(tempFolder & tempFileName)
                For Each attInternal In msgInternal.Attachments
                    sIntFname = attInternal.FileName
                    sExt = Mid(sIntFname, InStrRev(sIntFname, Chr(46)))
                    If sExt = ".pdf" Then
                        att.SaveAsFile tempFolder & sIntFname
                        Shell pdfApp & " /n /h /t " & tempFolder & sIntFname
                    End If
                Next
                msgInternal.Delete
                Kill tempFolder & tempFileName
            Case ".pdf"
                att.SaveAsFile tempFolder & sFname
                Shell pdfApp & " /n /h /t " & tempFolder & sFname
        End Select
    Next
lbl_Exit:
    Set msgInternal = Nothing
    Exit Sub
End Sub

---

Thanks again, gmayor. You started me off on the road of VBA for Outlook. Below is my first effort (admittedly 60% your code, 20% of skattoni's and 20% of mine). For anyone interested, this macro will loop through all items selected in the explorer window. If it finds a pdf attachment it saves it to c:\Test, likewise if it finds a message as an attachment it looks for pdf attachments in those too and saves them to the same place if it finds any. It also checks (credit to a previous post by gmayor) for duplicate filenames and renames any duplicate names ...(1), ...(2), etc in the destination folder:

Code:

---

Option Explicit
Sub msgAsAttachment() ' v1.1
   
    Dim CurrItem As MailItem
    Dim attSub As Attachment
    Dim msgInternal As MailItem
    Dim attInternal As Attachment
    Dim tempFileName As String
    Dim tempFolder As String
    Dim intMessage As Integer
    Dim intAttachment As Integer
    Dim attCurrent As Attachment
    Dim strAttachFName As String
   
    tempFolder = "C:\Test\"
    tempFileName = "dummy.msg"
   
    For Each CurrItem In ActiveExplorer.Selection ' The item selected on the explorer (i - index number if several)
     
        For intAttachment = 1 To CurrItem.Attachments.Count
            Set attCurrent = CurrItem.Attachments(intAttachment)
            If Right(attCurrent, 3) = "pdf" Then
                strAttachFName = FileNameUnique("C:\Test\", attCurrent.FileName, Right(attCurrent, 3))
                attCurrent.SaveAsFile tempFolder & strAttachFName
            ElseIf Right(attCurrent.FileName, 3) = "msg" Then
                attCurrent.SaveAsFile tempFolder & tempFileName
                Set msgInternal = CreateItemFromTemplate(tempFolder & tempFileName)
                For Each attSub In msgInternal.Attachments
                    If Right(attSub, 3) = "pdf" Then
                        strAttachFName = FileNameUnique("C:\Test\", attSub.FileName, Right(attSub, 3))
                        attCurrent.SaveAsFile tempFolder & strAttachFName
                    End If
                Next
                msgInternal.Delete
            End If
        Next
    Next
   
    Set msgInternal = Nothing
    Set CurrItem = Nothing
    Kill tempFolder & tempFileName
End Sub

Private Function FileNameUnique(strPath As String, strFileName As String, strExtension As String) As String
    Dim lngF As Long
    Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function
Private Function FileExists(filespec) As Boolean
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

---

Great stuff, thanks again both of you!

Incidentally, when I try to print a PDF that was an attachment of an attachment, I get the following message (and not otherwise):

Adobe Reader could not open [FILENAME] because it is either not a supported file type or because the file has been damaged (for example, it was sent as an email attachment and wasn't correctly decoded).

Hmmm.
I think the section should read as follows:

Code:

---

For Each attSub In msgInternal.Attachments
                    If Right(attSub.Filename, 3) = "pdf" Then
                        strAttachFName = FileNameUnique("C:\Test\", attSub.FileName, "pdf")
                        attCurrent.SaveAsFile tempFolder & strAttachFName
                    End If
                Next

---

Thanks again for your time, gmayor. I changed the code, but get the same results. Attachments of message attachments are saved to the folder, but whether the macro attempts to print them or whether you attempt to print them from within the folder yourself, the same error occurs. I am wondering what is the difference between an attachment and an attachment of an attachment from Adobe's point of view?

Here's my suggested culprit:

Code:

---

Set msgInternal = CreateItemFromTemplate(tempFolder & tempFileName)

---

A message with a PDF attachment is being "re-created" without the assistance of Acrobat, resulting in corruption to the attachment, I suspect. If I open a message with a message attachment and manually drag and drop it into, say my Inbox, I can run the macro and it saves and prints any PDF attachments without corruption. All I need is to be able to copy the message within the message into a particular Outlook folder and then process it from there with the macro...?

Hit a brick wall here. Quote from OutlookCode.com appears to confirm what I am discovering by trial and error:

"You cannot programmatically copy an attachment directly from one Outlook item to another. You must first save the item as a system file."

Is it really impossible to reproduce via VBA what a simple drag and drop can perform? I want to convert a message stored as an attachment into a message in its own right, without moving from the confines of Outlook.

Hmmm. I am not sure what is going on here.
If you add the line

Code:

---

msgInternal.Display

---

immerdiately after

Code:

---

Set msgInternal = CreateItemFromTemplate(tempFolder & tempFileName)

---

and remove the line

Code:

---

msgInternal.Delete

---

You will see that the message is created with the PDF attachment and the PDF is at that point a valid PDF. It then all goes wrong, and I cannot immediately spot the problem. The resulting 'pdf' file is not a PDF file. Examined with a hex editor it looks more like a message. Perhaps our Canadian friend can spot the deliberate mistake? ;)

I have a habit of jumping directly to Application.CreateItemFromTemplate https://msdn.microsoft.com/en-us/lib.../ff865637.aspx

I have not tested with the full solution but my usual fix is NameSpace.OpenSharedItem https://msdn.microsoft.com/en-us/lib.../ff869733.aspx

Code:

---

Set msgInternal = GetNamespace("MAPI").OpenSharedItem(tempFolder & tempFileName)

---

Unfortunately that doesn't take us any closer. The original code would open the attached message and would present the attachment(s) it contains, but when the attachment is saved the attachment is not a valid PDF file. The real issue is why

Code:

---

                For Each attSub In msgInternal.Attachments
                    If Right(attSub, 3) = "pdf" Then
                        strAttachFName = FileNameUnique("C:\Test\", attSub.FileName, Right(attSub, 3))
                        attCurrent.SaveAsFile tempFolder & strAttachFName
                    End If
                Next

---

doesn't save a valid file.