Unpacking a message with message attachments

[Pog]

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

[skatonni]

This demonstrates how to process an attached mailitem.


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

[Pog]

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?

[Pog]

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:


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?

[gmayor]

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:


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

[Pog]

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:


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!

[Pog]

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).

[gmayor]

Hmmm.
I think the section should read as follows:

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

[Pog]

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?

[Pog]

Here's my suggested culprit:


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...?

[Pog]

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.

[gmayor]

Hmmm. I am not sure what is going on here.
If you add the line
msgInternal.Displayimmerdiately after
Set msgInternal = CreateItemFromTemplate(tempFolder & tempFileName)
and remove the line
msgInternal.DeleteYou 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? ;)

[skatonni]

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

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


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

[gmayor]

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
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.