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