How to read the Inbox messages and delete attachments over a given size using VB and CDO 1.21

  • Article

Below is a sample:

 Here is an example:

    ' This example deletes all jpg file attachments over a certain size in an inbox.
   
    Const CONST_MAX_JPG_ATTACHMENT = 3000   ' TODO: Change this - max jpg file size
    Dim sErrorMessage As String
    Dim objSession As MAPI.Session
    Dim objAttach As MAPI.Attachment
    Dim strExServer As String
    Dim strExUser As String
    Dim objInbox As Folder
    Dim objMessages As Messages
    Dim objMessage As Message
    Dim objAttachments As Attachments
    Dim objAttachment As Attachment
    Dim lAttchmentCount As Long
    Dim lCounter As Long
    Dim lAttchmentSize As Long
   
    Dim sLine As String
    sLine = ""
   
     ' my specific settings
    strExServer = "myemailserver"     ' TODO: Change to the name of email servers or the servers TCP address, or TCP Address + ":" + port number
    strExUser = "mymailbox"           ' TODO: Change to your email mailbox name - the mailbox of the Domain User Account you are going to send from.
 
    'On Error GoTo ErrorCheck
   
    'Create Session and Logon
    Set objSession = New MAPI.Session
    objSession.Logon , , False, True, , True, strExServer & vbLf & strExUser
   
     'Create your Inbox object and get all the messages in the inbox.
     Set objInbox = objSession.Inbox
     Set objMessages = objInbox.Messages

     'Get the first message in the objMessages collection.
     Set objMessage = objMessages.GetFirst

    If objMessage Is Nothing Then
        MsgBox "No messages to process"
    Else
        'Set up a loop to run through all the messages in the inbox.
        Do
            With objMessage
                sLine = "[" & .TimeReceived & "] (" & .Size & " bytes) - " & .Subject & vbCrLf
                sLine = sLine & "           (Message Class: " & .Fields(CdoPR_MESSAGE_CLASS).Value & ")" & vbCrLf
               
                Set objAttachments = objMessage.Attachments
                lAttchmentCount = objAttachments.Count
               
                If lAttchmentCount > 0 Then
                    For lCounter = lAttchmentCount To 1 Step -1  ' Go backward in case you want to delete
                        Set objAttachment = objAttachments.Item(lCounter)
                       
                        sLine = sLine & "    Attachment: " & objAttachment.Name
                        lAttchmentSize = objAttachment.Fields(CdoPR_ATTACH_SIZE)
                        sLine = sLine & " (" & lAttchmentSize & " bytes) " & vbCrLf
                       
                        ' Test to see if the attachment should be deleted - TODO: Change Test as needed
                        If (lAttchmentSize > CONST_MAX_JPG_ATTACHMENT And Right(objAttachment.Name, 4) = ".jpg") Then
                            ' TODO: Uncomment the line below when you are sure you are ready to have attachemnts deleted
                            'objAttachments.Item(lCounter).Delete
                            sLine = "***  Attachment was a big jpg file - Deleted" & vbCrLf
                        End If
                    Next
                    Set objAttachment = Nothing
                   
                End If
                .Update
                Debug.Print sLine
            End With    'objMessage
           
            'Get the next message.
            Set objMessage = objMessages.GetNext
        Loop Until objMessage Is Nothing
    End If
   
    'Logoff your session and destroy your objects.
    objSession.Logoff
    Set objSession = Nothing
    Set objAttach = Nothing
    Set objInbox = Nothing
    Set objMessages = Nothing
    Set objMessage = Nothing
    Set objAttachments = Nothing
    Set objAttachment = Nothing