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

[jasmith4]

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

[JesusWept3 · Accepted solution]

Your best bet is to look at the message body itself If your policy is set to create a link to the attachments, then in the body it would have href pointing to download.asp? for each of those items As for the API, you will have to run that as the EVAdmin for it to work properly, you can use the indexing API part of it to get attachment names and such, the problem you will have though is the API documentation is only available to STEP members (typically partners)

[jasmith4]

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