用于Outlook的VBA附件卸妆-排除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