从发送给 Mac 用户或 SpiceWorks 的 Outlook 电子邮件中删除签名/附件

Question

所以这是我偶然发现的一个有趣的问题。我向 SpiceWorks 和 Mac 用户发送电子邮件时遇到了问题。

当用户遇到问题时，他们会向帮助台发送电子邮件。我们设置了个人 Outlook 电子邮件来处理帮助台工单。一旦票进入 Outlook 邮箱，它将自动发送到我们的 SpiceWorks 网站。

现在我们所有的电子邮件都有签名，并且某些签名带有小 png 图像徽标（Youtube、LinkedIn、Facebook 和 Twitter）。 当电子邮件到达 SpiceWorks 时，它会将这些 png 图像作为附件上传。这些附件会导致大多数问题，因为某些电子邮件线程甚至在作为帮助台票提交之前就已经很长时间了。他们最终可能会得到 20 多个相同的四个徽标 png 的附件。

我编码删除了该特定地址的所有附件，但一些用户发送了实际附件。我尝试按名称删除特定附件，但如果有相同的 .png 图像重复，它们只会迭代。 （img001 到 img004 现在是 img005 到 img009）

我在 HelpDesk Outlook 中找到了当前的 VBA 脚本。有人告诉我，Outlook 必须一直运行才能正常工作……有时。

我开始编写自己的脚本，它检查当前电子邮件是否发送到帮助台电子邮件地址，然后删除附件。还没有运气。

当前代码

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim msg As Outlook.MailItem
Dim recips As Outlook.Recipients
Dim str As String
Dim emailAddress As String
Dim prompt As String

Dim msgbody As String
msgbody = Item.Body   

  Set msg = Item 'Subject Message
  Set recips = msg.Recipients

  str = "HelpDesk"


  For x = 1 To GetRecipientsCount(recips)
    str1 = recips(x)
    If str1 = str Then
      'MsgBox str1, vbOKOnly, str1 'For Testing

      prompt = "Are you sure you want to send to " & str1 & "?" 'For Testing

      If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then 'For Testing
        Cancel = True
      End If

      'if attachments are there
    If Item.Attachments.Count > 0 Then

        'for all attachments
        For i = Item.Attachments.Count To 1 Step -1  

            'if the attachment's filename is similar to "image###.png", remove
            If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
                MsgBox ("Item Removed " + Item.Attachments(i))
                Item.Attachments.Remove (i)
            End If

        Next
    End If   

    End If
  Next x
End Sub

Public Function GetRecipientsCount(Itm As Variant) As Long
' pass in a qualifying item, or a Recipients Collection
Dim obj As Object
Dim recips As Outlook.Recipients
Dim types() As String

  types = Split("MailItem, AppointmentItem, JournalItem, MeetingItem, TaskItem", ",")

  Select Case True
    ' these items have a Recipients collection
    Case UBound(Filter(types, TypeName(Itm))) > -1
      Set obj = Itm
      Set recips = obj.Recipients
    Case TypeName(Itm) = "Recipients"
      Set recips = Itm
  End Select

  GetRecipientsCount = recips.Count
End Function

几个问题：

1.) 有没有办法在 Outlook 中设置规则（查看了多种可能性）或使用 Exchange Server 做一些事情来阻止这种情况发生？

2.) 使用 Vba 是否可以在发送电子邮件时删除或不允许签名？

如果有的话，我的最终目标只是防止将这些 .png 作为图像上传给 Mac 用户和 SpiceWorks。

我确信还有更多内容，但我很乐意回答给我的任何问题。

感谢您的任何帮助或指导！

Answer 1

如果我理解正确，您正在尝试删除发送到 SpiceWorks 的 .png 文件。如果是这样，请使用以下宏从 Outlook 邮箱发送到 SpiceWorks。在ItemSend 事件中，这将检查所有附件的文件名并删除带有.png 扩展名的那些。如果这不是您想要做的，请发回这里。谢谢。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    'if attachments are there
    If Item.Attachments.count > 0 Then

        'for all attachments
        For i = Item.Attachments.count To 1 Step -1

            'if the attachment's extension is .png, remove
            If Right(Item.Attachments(i).FileName, 4) = ".png" Then
                Item.Attachments.Remove (i)
            End If
        Next
    End If
End Sub

----- 更新为仅删除看起来像“image###.png”的附件 -----

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    'if attachments are there
    If Item.Attachments.count > 0 Then

        'for all attachments
        For i = Item.Attachments.count To 1 Step -1

            'if the attachment's filename is similar to "image###.png", remove
            If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
                Item.Attachments.Remove (i)
            End If

        Next
    End If
End Sub

-- 更新为仅删除

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    'if attachments are there
    If Item.Attachments.count > 0 Then

        'for all attachments
        For i = Item.Attachments.count To 1 Step -1

            'if attachment size is less than 10kb
            If Item.Attachments(i).Size < 10000 Then
                'if the attachment's filename is similar to "image###.png", remove
                If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
                    Item.Attachments.Remove (i)
                End If
            End If
        Next
    End If
End Sub