In VBA/Outlook, how to list attachments to EV-archived item

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