Как отфильтровать GIF-файлы при удалении вложений? - PullRequest
Новая
       7

Как отфильтровать GIF-файлы при удалении вложений?

0 голосов
/ 04 октября 2018

Когда я включаю фильтр в свою подпрограмму 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

1 Ответ

0 голосов
/ 04 октября 2018

Ваш код имел некоторые синтаксические ошибки.Они были исправлены в приведенном ниже коде. 

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"

...