Question

以下是我从其他一些来源拼凑而成的剧本。每次通过Microsoft Outlook 2013中的电子邮件规则收到新电子邮件时，它都会触发。该脚本应该看看传入的电子邮件并删除页面背景。

实际发生的事情是我得到一个小弹出窗口说新邮件已经到达，它将剥离出前景中已经成为焦点的电子邮件的背景！

因此，如果我点击带有html背景的电子邮件，以便它是预览窗格的焦点，然后收到一封新电子邮件，它将删除该重点电子邮件的背景...很棒...但我希望它检查新到达的消息！

有什么想法吗？

Sub CustomMailMessageRule(Item As Outlook.MailItem)
   MsgBox "Mail message arrived: " & Item.Subject
   Call ClearStationeryFormatting
End Sub

Sub ClearStationeryFormatting()
On Error GoTo ClearStationeryFormatting_Error
    Dim strEmbeddedImageTag As String
    Dim strStyle As String
    Dim strReplaceThis As String
    Dim intX As Integer, intY As Integer
    Dim myMessage As Outlook.MailItem

    ' First, check to see if we are in preview-pane mode or message-view mode
    ' If neither, quit out
    Select Case TypeName(Outlook.Application.ActiveWindow)
        Case "Explorer"
            Set myMessage = ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set myMessage = ActiveInspector.CurrentItem
        Case Else
            MsgBox ("No message selected.")
            Exit Sub
    End Select

    ' Sanity check to make sure selected message is actually a mail item
    If TypeName(myMessage) <> "MailItem" Then
       MsgBox ("No message selected.")
       Exit Sub
    End If

    ' Remove attributes from <BODY> tag
    intX = InStr(1, myMessage.HTMLBody, "<BODY", vbTextCompare)
    If intX > 0 Then
        intY = InStr(intX, myMessage.HTMLBody, ">", vbTextCompare)
        strReplaceThis = Mid(myMessage.HTMLBody, intX, intY - intX + 1)
    End If

    If strReplaceThis <> "" Then
        myMessage.HTMLBody = Replace(myMessage.HTMLBody, strReplaceThis, "<BODY>")
        strReplaceThis = ""
    Else
        Err.Raise vbObjectError + 7, , "An unexpected error occurred searching for the BODY tag in the e-mail message."
        Exit Sub
    End If

    ' Find and replace <STYLE> tag
    intX = InStr(1, myMessage.HTMLBody, "<STYLE>", vbTextCompare)
    If intX > 0 Then
        intY = InStr(8, myMessage.HTMLBody, "</STYLE>", vbTextCompare)
        strReplaceThis = Mid(myMessage.HTMLBody, intX, ((intY + 8) - intX))
    End If

    If strReplaceThis <> "" Then
        myMessage.HTMLBody = Replace(myMessage.HTMLBody, strReplaceThis, "")
    End If

    If InStr(1, myMessage.HTMLBody, "<center><img id=", vbTextCompare) > 0 Then
        strEmbeddedImageTag = "<center><img id="
        '"<center><img id=""ridImg"" src="citbannA.gif align=bottom></center>"
        intX = InStr(1, myMessage.HTMLBody, strEmbeddedImageTag, vbTextCompare)
        If intX = 0 Then
            Err.Raise vbObjectError + 8, , "An unexpected error occurred searching for the embedded image file name start tag in the e-mail message."
            Exit Sub
        End If
        intY = InStr(intX + Len(strEmbeddedImageTag), myMessage.HTMLBody, " align=bottom></center>", vbTextCompare)
        If intY = 0 Then
            Err.Raise vbObjectError + 9, , "An unexpected error occurred searching for the embedded image file name end tag in the e-mail message."
            Exit Sub
        End If
        strEmbeddedImageTag = Mid(myMessage.HTMLBody, intX, intY - intX)
        intX = InStr(1, myMessage.HTMLBody, "<CENTER>", vbTextCompare)
        intY = InStr(intX, myMessage.HTMLBody, "</CENTER>", vbTextCompare)
        strReplaceThis = Mid(myMessage.HTMLBody, intX, intY - intX) & "</CENTER>"
        myMessage.HTMLBody = Replace(myMessage.HTMLBody, strReplaceThis, "", , , vbTextCompare)
    End If

    ' Finally, saved modified message
    myMessage.Save

    On Error GoTo 0
    Exit Sub

ClearStationeryFormatting_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
    Resume Next
End Sub

Answer 1

您应该能够将要处理的邮件项目作为参数传递，即

Sub CustomMailMessageRule(Item As Outlook.MailItem)
   MsgBox "Mail message arrived: " & Item.Subject
   ClearStationeryFormatting Item
End Sub

Sub ClearStationeryFormatting(myMessage As Outlook.MailItem)
    On Error GoTo ClearStationeryFormatting_Error
    Dim strEmbeddedImageTag As String
    Dim strStyle As String
    Dim strReplaceThis As String
    Dim intX As Integer, intY As Integer

    ' Remove attributes from <BODY> tag

    '...

VBA - 侧重于错误电子邮件的Outlook脚本

1 个答案: