02-05-2013 01:01 PM
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
Solved! Go to Solution.
02-05-2013 02:43 PM
02-05-2013 02:43 PM
02-06-2013 02:54 PM
I want this to work for everybody, so I can't do any admin or API stuff. But it turns out I don't need it: if I parse the message's HTMLbody correctly I can find all the attachments' names and file sizes. I have to use HTMLbody, because Body doesn't always work.
Here's my complete code: it starts from the currently selected folder and finds all attachments matching the wildcard in allmessages, even vaulted ones, in that folder and below.
Option Explicit Sub SearchForAttachments() Dim WildCard$, NS As NameSpace, Fld As Folder, MI As MailItem, NA&, NF&, NI&, SF@, EVobj As Object On Error GoTo 0 'ABEND Set NS = GetNamespace("MAPI") Set Fld = Outlook.ActiveExplorer.CurrentFolder WildCard$ = InputBox$("Gimme a wildcard") If Len(WildCard$) Then WildCard$ = Replace$(WildCard$, "[", "[[]") WildCard$ = Replace$(WildCard$, "#", "[#]") WildCard$ = Replace$(WildCard$, "!", "[#]") Close Open Environ$("TEMP") & "\Attachments.txt" For Output As #FreeFile() Close Call DirAttachments(Fld, WildCard$, NA&, NF&, NI&, SF@) LogIt SF@ & " bytes in " & NA& & " attachments in " & NI& & " items (with attachments) in " & NF& & " folders under " & Fld.Name 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$, NA&, NF&, NI&, SF@, 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 Call ListAttachments(I, WildCard$, NA&, NF&, NI&, SF@, Prefix$) End Select Next For Each F In Fld.Folders Call DirAttachments(F, WildCard$, NA&, NF&, NI&, SF@, Prefix$ & "\" & Fld.Name) Next End Sub Sub ListAttachments(I As Object, WildCard$, NA&, NF&, NI&, SF@, Prefix$) Dim Att As Attachment, MI As MailItem, AttName$, AttSplit As Variant, A& Dim FSsplit As Variant, FName$, Fsize@, FSunits$, F& NI& = NI& + 1 If I.MessageClass = "IPM.Note.EnterpriseVault.Shortcut" Then ' See if this has attachments A& = InStrRev(I.HTMLBody, "<DIV class=EVAttachBanner>Attachments:</DIV>") If A& > 0 Then Do ' Each one starts after URL ending with attachment ID number A& = InStr(A&, I.HTMLBody, "&AttachmentId="): If A& = 0 Then Exit Do F& = 1 + InStr(A&, I.HTMLBody, ">") ' and ends with end of AREF A& = -1 + InStr(F&, I.HTMLBody, " </A>") FName$ = Mid$(I.HTMLBody, F&, 1 + A& - F&) If FName$ Like WildCard$ Then ' Size follows in parentheses A& = 1 + InStr(A&, I.HTMLBody, "(") F& = -1 + InStr(A&, I.HTMLBody, ")") FSsplit = Split(Mid$(I.HTMLBody, A&, 1 + F& - A&)) Fsize@ = FSsplit(0): FSunits$ = FSsplit(1) Select Case FSunits$ ' Convert file size to bytes Case "KB": Fsize@ = Fsize@ * 1024 Case "MB": Fsize@ = Fsize@ * 1024 ^ 2 Case "GB": Fsize@ = Fsize@ * 1024 ^ 3 Case "TB": Fsize@ = Fsize@ * 1024 ^ 4 End Select Fsize@ = Int(Fsize@ + 0.5@) LogIt Prefix$ & vbTab & I.Subject & vbTab & I.ReceivedTime & vbTab & FName$ & vbTab & Fsize@ NA& = NA& + 1 SF@ = SF@ + Fsize@ End If Loop End If Else For Each Att In I.Attachments: DoEvents If Att.Type = olByValue And Att.FileName Like WildCard$ Then LogIt Prefix$ & vbTab & I.Subject & vbTab & I.ReceivedTime & vbTab & Att.FileName & vbTab & Att.Size NA& = NA& + 1 SF@ = SF@ + Att.Size End If Next End If End Sub Sub LogIt(Msg$) Dim FH% Close FH% = FreeFile() Open Environ$("TEMP") & "\Attachments.txt" For Append As #FH% Print #FH%, Msg$ Close End Sub