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", "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

Answer 1

您的代码有一些语法错误。这些已在下面的代码中得到纠正。

If lngCount > 0 Then
    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
                Case ".gif", "gif"

            End Select
        End If
    Next
End If

如果您打算删除gif附件，则可能要在att.Item(i).Delete之后的行上尝试Case ".gif", "gif"

删除附件时如何过滤出gif文件？

1 个答案: