VBA для удаления вложений для Outlook - исключить GIF-файлы

Question

Когда я запускаю следующую подпрограмму VBA, она не отфильтровывает все файлы GIF от исключения.Подпрограмма должна удалять вложения из электронных писем и заменять их ссылкой.

Я ожидаю, что при запуске подпрограмма пропустит все экземпляры вложений gif и оставит их.Это связано с темами электронной почты, в которых пользователи имеют изображения gif в своей подписи, а удаление файлов gif нарушит чистоту потока и затруднит для пользователей выяснение того, кто написал какую часть письма

Private Sub BrowseFolder()

    Dim oShell As Object
    Set oShell = CreateObject("Shell.Application")

    Dim fsSaveFolder As Object
    Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)

    'Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", NO_OPTIONS, "C:\users\" & Environ("Username") & "Documents\Outlook Files")
    If fsSaveFolder Is Nothing Then Exit Sub
    ' Note: BrowseForFolder doesn't add a trailing slash

    ' Ask the user to select an Outlook folder to process
    Dim olPurgeFolder As Outlook.MAPIFolder
    Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
    If olPurgeFolder Is Nothing Then Exit Sub

    Dim msg As Variant
    Dim att As Outlook.Attachments
    Dim sSavePathFS As String
    Dim sDelAtts

    For Each msg In olPurgeFolder.Items

        On Error GoTo GetAttachments_err
        sDelAtts = ""

        If TypeName(msg) = "MailItem" Then
            If msg.MessageClass <> "IPM.Note.SMIME.MultipartSigned" Then
                If msg.MessageClass <> "IPM.Note.Secure.Sign" Then
                    'If msg.Attachments.Count > 0 Then   '& olByValue <> 5 & olByValue <> 6 Then

                    Set att = msg.Attachments
                    lngCount = att.Count
                    DelAtts = ""

                    If lngCount > 0 Then

                        ' We need to use a count down loop for removing items
                        ' from a collection. Otherwise, the loop counter gets
                        ' confused and only every other item is removed.

                        For i = lngCount To 1 Step -1

                            ' Save attachment before deleting from item.
                            ' Get the file name.
                            strFile = att.Item(i).FileName
                            ' This code looks at the last 4 characters in a filename
                            sFileType = LCase$(Right$(strFile, 4))

                            If att.Item(i).Size < 5234111 Then

                                Select Case sFileType
                                    ' Add additional file types below
                                Case ".gif"

                                Case Else
                                    'While msg.Attachments.Count > 0
                                    On Error GoTo GetAttachments_err

                                    ' Save the attachment to the file system
                                    sSavePathFS = fsSaveFolder.Self.Path & "\"
                                    attachName = msg.Attachments(1).FileName
                                    msg.Attachments(1).SaveAsFile sSavePathFS & Format(msg.ReceivedTime, "mm-dd-yyyy-ss") & attachName

                                    ' Build up a string to denote the file system save path(s)
                                    ' Format the string according to the msg.BodyFormat.
                                    If msg.BodyFormat <> olFormatHTML Then
                                        sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & Format(msg.ReceivedTime, "mm-dd-yyyy-ss") & attachName & ">"
                                    Else
                                        sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & Format(msg.ReceivedTime, "mm-dd-yyyy-ss") & attachName & "'>" & sSavePathFS & Format(msg.ReceivedTime, "mm-dd-yyyy-ss") & attachName & "</a>"
                                    End If

                                    ' Delete the current attachment. We use a "1" here instead of an "i"
                                    ' because the .Delete method will shrink the size of the msg.Attachments
                                    ' collection for us. Use some well placed Debug.Print statements to see
                                    ' the behavior. ~~
                                    msg.Attachments(1).Delete

                                    '  Wend
                                End Select

                            End If
                        Next

                        ' Modify the body of the msg to show the file system location of
                        ' the deleted attachments.
                        If msg.BodyFormat <> olFormatHTML Then
                            msg.Body = vbCrLf & vbCrLf & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & msg.Body
                        Else
                            msg.HTMLBody = "<p></p><p>" & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>" & msg.HTMLBody
                        End If

                        ' Save the edits to the msg. If you forget this line, the attachments will not be deleted. ~~
                        msg.Save
                    End If
                End If
            End If
        End If
    Next

GetAttachments_exit:

    Set att = Nothing
    Set fso = Nothing
    Set olPurgeFolder = Nothing
    Exit Sub

    ' Handle errors
GetAttachments_err:

    If Err.Description = "Outlook cannot perform this action on this type of attachment." Then
        Err.Clear
        Resume Next
    End If

    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: GetAttachments" _
         & vbCrLf & "Error Number: " & Err.Number _
           , vbCritical, "Error!"

    Resume GetAttachments_exit

End Sub