Question

所以这是我偶然发现的一个有趣的问题。我通过向SpiceWorks和Mac用户发送电子邮件来解决问题。

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

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

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

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

我开始编写自己的脚本，检查当前的电子邮件是否会转到HelpDesk电子邮件地址，然后删除attachemnts。没有运气了。

当前代码

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

-----更新为仅删除＆lt; 10kb的附件，看起来像“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 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

从去往Mac用户或SpiceWorks的Outlook电子邮件中删除签名/附件

1 个答案: