有空我会分部分回答你的问题。其他人可能会在我之前找到重要的部分。
我已经编辑了您的问题。我有几句话没看懂，所以我查看了源代码，发现我的怀疑是正确的，您包含的字符少于字符。 Stack Overflow 允许有限数量的 Html 标签。任何其他看起来像 Html 标记的东西都会被忽略。我用“<”替换了每个“
你有：
NewBody = Replace(obj.HTMLBody, strDelete01, "")
NewBody = Replace(obj.HTMLBody, strDelete02, "")
NewBody = Replace(obj.HTMLBody, strDelete03, "")
NewBody = Replace(obj.HTMLBody, strDelete04, "")
If NewBody <> "" Then
每个Replace（第一个除外）都会覆盖由前一个Replace 创建的NewBody 的值。你似乎认为如果没有找到strDelete04，NewBody 就会为空。不，如果找不到strDelete04，NewBody 将是obj.HTMLBody 的副本。
你需要这样的东西：
NewBody = Replace(obj.HTMLBody, strDelete01, "")
NewBody = Replace(NewBody, strDelete02, "")
NewBody = Replace(NewBody, strDelete03, "")
NewBody = Replace(NewBody, strDelete04, "")
If NewBody <> obj.HTMLBody Then
' One or more delete strings found and removed
您说 CRLF 不在固定位置。如果是这样，对您的代码的任何简单修改都不会产生您想要的效果。我将向您展示如何实现您所寻求的效果，但首先我必须创建一些包含您的文本的电子邮件，以便我可以测试我的代码。
第 2 部分
在仔细查看了您的 Html 图像后，我相信有一个简单的解决方案。文本中的两个 CRLF 替换空格。如果总是这样，您可以使用：
NewBody = Replace(obj.HTMLBody, vbCr & vbLf, " ")
这将删除任何出现在 Html 中的任何 CRLF。是否存在额外的 CRLF 无关紧要，因为在显示文档时，Html 文档中的任何空白字符（包括 CR 和 LF）字符串都会被单个空格替换。
您完成删除不需要的文本：
Dim strDelete = "Diese E-Mail kommt von Personen außerhalb " & _
"der Stadtverwaltung. Klicken Sie nur auf " & _
"Links oder Dateianhänge, wenn Sie die Personen " & _
"für vertrauenswürdig halten."
NewBody = Replace(NewBody, strDelete, "")
如果上述方法不起作用，您需要更方便的诊断技术。将整个电子邮件保存为 Html 可能很容易，但您无法确定结果与 VBA 宏所看到的有何不同。您想知道 Outlook 是否以 Html 以外的格式存储电子邮件。我无法想象为什么 Outlook 会将传入的 SMTP 邮件转换为某种机密格式，然后在用户希望查看时将其转换回来。如果 Outlook 确实有一个秘密格式，它对 VBA 程序员是完全隐藏的。
以下是我使用的诊断工具的简单版本。如果您需要更高级的东西，我可以提供，但让我们先尝试一下。
将下面的代码复制到 Outlook 模块。选择其中一封电子邮件，然后运行宏 DsplHtmlBodyFromSelectedEmails。电子邮件的整个 Html 正文将以可读的格式输出到即时窗口。我相信我已经包含了宏调用的所有子例程。如果我没有，我会提前道歉。如果您收到有关未定义例程的消息，请告诉我，我会将其添加到答案中。
Sub DsplHtmlBodyFromSelectedEmails()
' Select one or emails then run this macro. For each selected email, the Received Time, the Subject and the Html body are output to the Immediate Window. Note: the Immediate Window can only display about 200 lines before
The older lines are lost.
Dim Exp As Explorer
Dim Html As String
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
With ItemCrnt
If .Class = olMail Then
Debug.Print .ReceivedTime & " " & .Subject
Call OutLongTextRtn(Html, "Html", .HtmlBody)
Debug.Print Html
End If
End With
Next
End If
End Sub
Sub OutLongTextRtn(ByRef TextOut As String, ByVal Head As String, _
ByVal TextIn As String)
' * Break TextIn into lines of not more than 100 characters
' and append to TextOut.
' * The output is arranged so:
' xxxx|sssssssssssssss|
' |sssssssssssssss|
' |ssssssssss|
' where "xxxx" is the value of Head and "ssss..." are characters from
' TextIn. The third line in the example could be shorter because:
' * it contains the last few characters of TextIn
' * there a linefeed in TextIn
' * a <xxx> string recording whitespace would have been split
' across two lines.
If TextIn = "" Then
' Nothing to do
Exit Sub
End If
Const LenLineMax As Long = 100
Dim PosBrktEnd As Long ' Last > before PosEnd
Dim PosBrktStart As Long ' Last < before PosEnd
Dim PosNext As Long ' Start of block to be output after current block
Dim PosStart As Long ' First character of TextIn not yet output
TextIn = TidyTextForDspl(TextIn)
TextIn = Replace(TextIn, "lf›", "lf›" & vbLf)
PosStart = 1
Do While True
PosNext = InStr(PosStart, TextIn, vbLf)
If PosNext = 0 Then
' No LF in [Remaining] TextIn
'Debug.Assert False
PosNext = Len(TextIn) + 1
End If
If PosNext - PosStart > LenLineMax Then
PosNext = PosStart + LenLineMax
End If
' Check for <xxx> being split across lines
PosBrktStart = InStrRev(TextIn, "‹", PosNext - 1)
PosBrktEnd = InStrRev(TextIn, "›", PosNext - 1)
If PosBrktStart < PosStart And PosBrktEnd < PosStart Then
' No <xxx> within text to be displayed
' No change to PosNext
'Debug.Assert False
ElseIf PosBrktStart > 0 And PosBrktEnd > 0 And PosBrktEnd > PosBrktStart Then
' Last or only <xxx> totally within text to be displayed
' No change to PosNext
'Debug.Assert False
ElseIf PosBrktStart > 0 And _
(PosBrktEnd = 0 Or (PosBrktEnd > 0 And PosBrktEnd < PosBrktStart)) Then
' Last or only <xxx> will be split across rows
'Debug.Assert False
PosNext = PosBrktStart
Else
' Are there other combinations?
Debug.Assert False
End If
'Debug.Assert Right$(Mid$(TextIn, PosStart, PosNext - PosStart), 1) <> "‹"
If TextOut <> "" Then
TextOut = TextOut & vbLf
End If
If PosStart = 1 Then
TextOut = TextOut & Head & "|"
Else
TextOut = TextOut & Space(Len(Head)) & "|"
End If
TextOut = TextOut & Mid$(TextIn, PosStart, PosNext - PosStart) & "|"
PosStart = PosNext
If Mid$(TextIn, PosStart, 1) = vbLf Then
PosStart = PosStart + 1
End If
If PosStart > Len(TextIn) Then
Exit Do
End If
Loop
End Sub
Function TidyTextForDspl(ByVal Text As String) As String
' Tidy Text for display 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 ‹n s› where n is number of repeats
' Replace multiple LFs by ‹n lf› of white space character
' Replace multiple CRs by ‹cr› or ‹n cr›
' Replace multiple TBs by ‹n tb›
' Replace multiple non-break spaces by ‹n nbs›
' Replace multiple CRLFs by ‹n crlf›
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> by <n 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