Outlook VBA Script that gets info on Attachments in currently selected email

Option Explicit

' VBA Script that gets info on Attachments of Currently Selected Email
' Use Tools->Macro->Security to allow Macros to run, then restart Outlook
' Run Outlook, Press Alt+F11 to open VBA
' Make sure you have selected an email with Attachments before running
' Programming by Greg Thatcher, http://www.GregThatcher.com
Public Sub GetAttachmentsOfCurrentEmail()
    Dim Session As Outlook.NameSpace
    Dim currentExplorer As Explorer
    Dim Selection As Selection
    Dim currentItem As Object
    Dim currentMail As MailItem
    Dim attachment As attachment
    Dim Report As String

    

    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection

    For Each currentItem In Selection
        If currentItem.Class = olMail Then
            Set currentMail = currentItem
            For Each attachment In currentMail.Attachments
                Report = Report & GetAttachmentInfo(attachment)
                Report = Report & vbCrLf & "------------------------------------------------------------------------" & vbCrLf
            Next

            Call CreateReportAsEmail("Attachment Report", Report)
        End If
    Next

End Sub

 

Public Function GetAttachmentInfo(attachment As attachment)
    On Error GoTo On_Error
    Dim Report

    GetAttachmentInfo = ""

    Report = Report & "Block Level: " & attachment.BlockLevel & vbCrLf
    Report = Report & "Display Name: " & attachment.DisplayName & vbCrLf
    Report = Report & "File Name: " & attachment.FileName & vbCrLf
    Report = Report & "Index: " & attachment.Index & vbCrLf
    Report = Report & "Path Name: " & attachment.PathName & vbCrLf
    Report = Report & "Position: " & attachment.Position & vbCrLf
    Report = Report & "Size: " & attachment.Size & vbCrLf
    Report = Report & "Type: " & attachment.Type & vbCrLf
    
    GetAttachmentInfo = Report

Exiting:
        Exit Function

On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting

End Function

 
' VBA SubRoutine which displays a report inside an email
' Programming by Greg Thatcher, http://www.GregThatcher.com
Public Sub CreateReportAsEmail(Title As String, Report As String)
    On Error GoTo On_Error

    Dim Session As Outlook.NameSpace
    Dim mail As MailItem
    Dim MyAddress As addressEntry
    Dim Inbox As Outlook.Folder

    Set Session = Application.Session
    Set Inbox = Session.GetDefaultFolder(olFolderInbox)
    Set mail = Inbox.Items.Add("IPM.Mail")

    mail.Subject = Title
    mail.Body = Report

    mail.Save
    mail.Display
    

Exiting:
        Set Session = Nothing
        Exit Sub

On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting

End Sub