我们的组织在外部电子邮件的主题行中添加了[EXTERNAL]，并在电子邮件正文中添加了“注意：”字样。他们也没有修复迭代，因此每次对其进行回复时，都会添加另一个[EXTERNAL]和“ Caution：”字样。
我已经从互联网上整理了两个不同的脚本，以在我发送电子邮件时消除此烦恼，但希望它在电子邮件到达时运行。当前的脚本提示输入MsgBox，主要是因为我不知道如何删除它们。
Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Item.HTMLBody = Replace(Item.HTMLBody, "CAUTION: This email originated from outside of the organization. Do not reply, click links, or open attachments unless you recognize the sender and know the content is safe.", "")
Dim strSubject As String
If InStr(Item.Subject, "[EXTERNAL]") > 0 Then
'If you don't want the prompt,
'You can remove the MsgBox line and its correspoding "Else … End If" lines.
If MsgBox("Do you want to remove the prefix '[EXTERNAL]'?", vbYesNo) = vbYes Then
strSubject = Replace(Item.Subject, "[EXTERNAL]", "", vbTextCompare)
Else
strSubject = Item.Subject
End If
End If
If InStr(Item.Subject, "[EXTERNAL]RE:") > 0 Then
If MsgBox("Do you want to remove the prefix '[EXTERNAL]RE:'?", vbYesNo) = vbYes Then
strSubject = Replace(Item.Subject, "[EXTERNAL]RE:", "", vbTextCompare)
Else
strSubject = Item.Subject
End If
End If
Item.Subject = Trim(strSubject)
Item.Save
End Sub
消息到达时，脚本将运行以删除[EXTERNAL]的所有迭代，将其余单词留在主题行中，并删除警告语
答案 0 :(得分：0)
这不是一个完整的答案。我需要您发现一些信息，而当我编写答案的下一部分时，此答案将使您能够进行发现。
对您现有代码的一些评论
问题1
您说您不知道如何删除提示。相关代码为；
'If you don't want the prompt,
'You can remove the MsgBox line and its correspoding "Else … End If" lines.
If MsgBox("Do you want to remove the prefix '[EXTERNAL]'?", vbYesNo) = vbYes Then
strSubject = Replace(Item.Subject, "[EXTERNAL]", "", vbTextCompare)
Else
strSubject = Item.Subject
End If
此评论不是很有帮助。如果您对VBA（或使用If ... Then ... Else ... End If构造的任何语言）有一定的了解，那么您将知道如何删除提示。如果您不太了解，则说明不清楚。作者的意思是，这样做：
Remove If MsgBox("Do you want to remove the prefix '[EXTERNAL]'?", vbYesNo) = vbYes Then
Keep strSubject = Replace(Item.Subject, "[EXTERNAL]", "", vbTextCompare)
Remove Else
Remove strSubject = Item.Subject
Remove End If
也就是说，删除MsgBox行，删除Else…End If行，并将所有行保留在Then和Else之间。
问题2
您还有第二个块将“ [EXTERNAL] Re：”删除。这将无法正常工作。
第一块将已编辑或未编辑的主题放置在变量strSubject中。第二个块检查Item.Subject，因此第一个块所做的所有操作都将丢失。
如果您修改了第二个块以检查变量strSubject，它仍然将不起作用，因为您已经删除了所有的“ [EXTERNAL]”，因此将找不到“ [EXTERNAL] Re：” 。如果要从字符串中删除所有“ Xxxx”和所有“ XxxxYyyy”，则必须先删除较长的子字符串。
问题3
我认为第二个区块不会达到您想要的效果。大多数（全部？）电子邮件软件包都添加“ Re：”或“ RE：”，类似于回复主题。为什么只从外部电子邮件中删除“ Re：”。我将全部删除或全部删除。我怀疑您正在尝试处理这种情况：
如果添加代码以删除“ [EXTERNAL]”，则将出现诸如“ Re：Re：xxxxxxx”和“ Re：Re：Re：xxxxxxx”和“ Re：Re：Re：Re：xxxxxxx”之类的主题取决于删除“ [EXTERNAL]”之前电子邮件集会持续了多长时间。也许在删除“ [EXTERNAL] Re”之前删除所有“ [EXTERNAL] Re：”会有所帮助。
问题4
除非已更改，否则请不要保存电子邮件。即使您的代码未更改，您的代码也会保存它。我不知道您保存电子邮件时会发生什么事情，但是我知道Outlook可以节省修改电子邮件的时间，并且显然必须找到修改后的电子邮件的空间并丢弃原始版本。
您需要以下内容：
strSubject = Item.Subject
Code to perform Edit 1 if appropriate.
Code to perform Edit 2 if appropriate.
Code to perform Edit 3 if appropriate.
: : : : : : :
If strSubject <> Item.Subject Then
Item.Subject = strSubject
Item.Save
End If
设计新代码
在我看来，您有三个要求：
我希望需求2的代码也可以处理需求3，但这并不确定。要求1是紧急要求，因为一旦满足此要求，情况就不会恶化。您想要答复的整理电子邮件将在接下来。闲暇时可以整理旧的对话。
为了能够测试我认为会有所帮助的代码，我需要一些测试电子邮件。
在辅助帐户中，我创建了一封简单的电子邮件。然后，我在主题上添加了“ [EXTERNAL]”，在主体上添加了“来自外部来源的警告电子邮件”，以尝试匹配系统的功能。我将该电子邮件发送到了我的主帐户，并在该帐户进行了回复。回到我的辅助帐户，我创建了一个回复，并再次添加了“ [[EXTERNAL]””和“来自外部来源的警告电子邮件”。经过几次或重复之后，我收到了这封电子邮件：
Subject: [EXTERNAL]RE: [EXTERNAL]RE: [EXTERNAL]Test
Caution email from external source
Reply 4
From: Tony@AcmeProducts.com
Sent: 04 April 2019 13:33
To: John@SomeOtherCompany.com
Subject: RE: [EXTERNAL]RE: [EXTERNAL]Test
Reply 3
From: John@SomeOtherCompany.com
Sent: 04 April 2019 13:30
To: Tony@AcmeProducts.com
Subject: [EXTERNAL]RE: [EXTERNAL]Test
Caution email from external source
Reply 2
From: Tony@AcmeProducts.com
Sent: 04 April 2019 13:20
To: John@SomeOtherCompany.com
Subject: RE: [EXTERNAL]Test
Reply 1
From: John@SomeOtherCompany.com
Sent: 04 April 2019 12:04
To: Tony@AcmeProducts.com
Subject: [EXTERNAL]Test
Caution email from external source
Test text. Test text. Test text. Test text. Test text.
上面是我打开电子邮件时看到的内容，只是我修改了“收件人”和“发件人”值以隐藏我的电子邮件地址。
您的警告文字与我的不同。您可能只是删除看到的字符串，但有可能无法删除，因此您必须确定HTML正文中的确切内容。
将以下内容复制到Outlook模块：
Public Sub CallSubForSelectedEmails()
Dim Exp As Explorer
Dim InxA As Long
Dim ItemCrnt As MailItem
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Please select one or more emails then try again", vbOKOnly)
Exit Sub
Else
For Each ItemCrnt In Exp.Selection
If ItemCrnt.Class = olMail Then
Call DsplCautionText(ItemCrnt)
End If
Next
End If
End Sub
Sub DsplCautionText(ItemCrnt As Outlook.MailItem)
Dim LcHtmlBody
Dim PosCaution As Long
Dim PosDsplStart As Long
With ItemCrnt
LcHtmlBody = LCase(.HtmlBody)
PosCaution = 1
Debug.Print "-----" & .ReceivedTime & " " & .Subject
Do While True
PosCaution = InStr(PosCaution, LcHtmlBody, "caution")
If PosCaution = 0 Then
' No [more] cautions
Exit Do
End If
If PosCaution <= 20 Then
PosDsplStart = 1
Else
PosDsplStart = PosCaution - 20
End If
Debug.Print PadL(PosDsplStart, 5) & " " & TidyTextForDspl(Mid$(.HtmlBody, PosDsplStart, 200))
PosCaution = PosCaution + 1
Loop
End With
End Sub
Public Function TidyTextForDspl(ByVal Text As String) As String
' Tidy Text for dsplay by replacing white space with visible strings:
' Leave single space unchanged
' Replace single LF by ‹lf›
' Replace single CR by ‹cr›
' Replace single TB by ‹tb›
' Replace single non-break space by ‹nbs›
' Replace single CRLF by ‹crlf›
' Replace multiple spaces by ‹# s› where # is number of repeats
' Replace multiple LFs by ‹# lf› of white space character
' Replace multiple CRs by ‹# cr›
' Replace multiple TBs by ‹# tb›
' Replace multiple non-break spaces by ‹# nbs›
' Replace multiple CRLFs by ‹# crlf›
' 15Mar16 Coded
' 3Feb19 Replaced "{" (\x7B) and "}" (\x7D) by "‹" (\u2039) and "›" (\u203A)
' on the grounds that the angle quotation marks were not likely to
' appear in text to be displayed.
' 5Feb19 Add code to treat CRLF as unit
' 28Mar19 Code to calculate PosWsChar after "<x>...<x>" converted to "<# x>"
' incorrect if "<x>...<x>" at the start of the string. Unlikely it
' was correct in other situations but this did not matter since the
' calculated value would be before the next occurrence of "<x>...<x>".
' But, if the string was near the beginning of the string, the
' calculated value was negative and the code crashed.
Dim InsStr As String
Dim InxWsChar As Long
Dim NumWsChar As Long
Dim PosWsChar As Long
Dim RetnVal As String
Dim WsCharCrnt As Variant
Dim WsCharValue As Variant
Dim WsCharDspl As Variant
WsCharValue = VBA.Array(" ", vbCr & vbLf, vbLf, vbCr, vbTab, Chr(160))
WsCharDspl = VBA.Array("s", "crlf", "lf", "cr", "tb", "nbs")
RetnVal = Text
' Replace each whitespace individually
For InxWsChar = 0 To UBound(WsCharValue)
RetnVal = Replace(RetnVal, WsCharValue(InxWsChar), "‹" & WsCharDspl(InxWsChar) & "›")
Next
' Look for repeats. If found replace <x><x><x><x>... by <# x>
For InxWsChar = 0 To UBound(WsCharValue)
'Debug.Assert InxWsChar <> 1
PosWsChar = 1
Do While True
InsStr = "‹" & WsCharDspl(InxWsChar) & "›"
PosWsChar = InStr(PosWsChar, RetnVal, InsStr & InsStr)
If PosWsChar = 0 Then
' No [more] repeats of this <x>
Exit Do
End If
' Have <x><x>. Count number of extra <x>s
NumWsChar = 2
Do While Mid(RetnVal, PosWsChar + NumWsChar * Len(InsStr), Len(InsStr)) = InsStr
NumWsChar = NumWsChar + 1
Loop
RetnVal = Mid(RetnVal, 1, PosWsChar - 1) & _
"‹" & NumWsChar & " " & WsCharDspl(InxWsChar) & "›" & _
Mid(RetnVal, PosWsChar + NumWsChar * Len(InsStr))
PosWsChar = PosWsChar + Len(InsStr) + Len(NumWsChar)
Loop
Next
' Restore any single spaces
RetnVal = Replace(RetnVal, "‹" & WsCharDspl(0) & "›", " ")
TidyTextForDspl = RetnVal
End Function
稍后我将解释上面的代码。目前，我只希望您选择一些此类外部电子邮件并运行宏CallSubForSelectedEmails()。通过我的电子邮件，我得到“即时窗口”输出：
-----04/04/2019 13:34:24 [EXTERNAL]RE: [EXTERNAL]RE: [EXTERNAL]Test
2161 ><p class=MsoNormal>Caution email from external source<o:p></o:p></p><p class=MsoNormal><o:p> …
3551 ><p class=MsoNormal>Caution email from external source<o:p></o:p></p><p class=MsoNormal><o:p> …
4986 ><p class=MsoNormal>Caution email from external source<o:p></o:p></p><p class=MsoNormal><o:p> …
-----04/04/2019 13:30:10 [EXTERNAL]RE: [EXTERNAL]Test
1953 ><p class=MsoNormal>Caution email from external source<o:p></o:p></p><p class=MsoNormal><o:p> …
3290 ><p class=MsoNormal>Caution email from external source<o:p></o:p></p><p class=MsoNormal><o:p> …
-----04/04/2019 12:04:09 [EXTERNAL]Test
1563 ><p class=MsoNormal>Caution email from external source<o:p></o:p></p><p class=MsoNormal><o:p> …
注1：...表示我已将行截断。注2：第一个警告文本在Html正文中的字符位置1953处，因为标头中有很多字符。注意3：对于每一行，我都搜索了“注意”，然后显示200个字符（从20个字符开始）。我已将行截断，因为在这种情况下，我不需要所有这些信息。我希望你也不会。
尖括号中的任何内容都是Html标签。 “
”是一个开始标记。 “
”是结束标记。对于我的电子邮件，警告文本不包含任何标签。这意味着我可以将“来自外部来源的警告电子邮件”替换为“”，而不会干扰HTML。我希望您的警告文字相似，但可能并非如此。请按照我的要求运行宏CallSubForSelectedEmails()。您的警告文字简单吗？每个例子都一样吗？