In VBA/Outlook, how to list attachments to EV-archived item
I'm trying to write a utility in VBA/Outlook which will list DIR-style the names of files attached to messages. But we have Enterprise Vault, and I don't know what to do with messages in the vault.
I can detect vaulted messages by checking whether MessageClass = "IPM.Note.EnterpriseVault.Shortcut", and I find they all have one attachment named "@". If a message isn't vaulted, I can enumerate any attachments and spit out their names along with the message's folder path, subject line and received date to help the user find the message.
How can I open a vaulted message, preferably without restoring it, just to get a list of its attachments? Please don't forget to point me to the library I should add to Tools / References -- all I can find on Google is CreateObject("EnterpriseVault.ContentManagementAPI"), but it fails.
Here's my code so far:
Option Explicit Sub SearchForAttachments() Dim WildCard$, FH%, Fld As Folder, MI As MailItem, NA&, NF&, NI& On Error GoTo 0 'ABEND Set Fld = Outlook.ActiveExplorer.CurrentFolder WildCard$ = InputBox$("Gimme a filename wildcard like '*.*'") If Len(WildCard$) Then Close FH% = FreeFile() 'Open Environ$("TEMP") & "\Attachments.txt" For Random As #FH% Call DirAttachments(Fld, WildCard$, FH%, NA&, NF&, NI&) Debug.Print NA& & " attachments in " & NI& & " items (with attachments) in " & NF& & " folders under " & Fld.Name 'Close End If ABEND: If Err.Number Then MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, , Err.HelpContext, Err.HelpContext Close End Sub Sub DirAttachments(Fld As Folder, WildCard$, FH%, NA&, NF&, NI&, Optional Prefix$ = "") Dim I As Object, MI As MailItem, F As Folder Prefix$ = Prefix$ & "\" & Fld.Name NF& = NF& + 1 For Each I In Fld.Items: DoEvents ': Debug.Print "."; Select Case TypeName$(I) Case "MailItem" If I.Attachments.Count > 0 Then 'And I.MessageClass <> "IPM.Note.EnterpriseVault.Shortcut" Call ListAttachments(I, WildCard$, FH%, NA&, NF&, NI&, Prefix$) End If End Select Next For Each F In Fld.Folders Call DirAttachments(F, WildCard$, FH, NA&, NF&, NI&, Prefix$ & "\" & Fld.Name) Next End Sub Sub ListAttachments(I As Object, WildCard$, FH%, NA&, NF&, NI&, Prefix$) Dim A As Attachment, MI As MailItem ', First As Boolean 'First = True NI& = NI& + 1 For Each A In I.Attachments: DoEvents If A.Type = olByValue Then 'And A.FileName Like WildCard$ 'If First Then Debug.Print: Debug.Print Prefix$ & "\" & I.Subject & " (" & I.ReceivedTime & ")": First = False Debug.Print Prefix$ & vbTab & I.Subject & vbTab & I.ReceivedTime & vbTab & A.FileName NA& = NA& + 1 End If Next End Sub