我试图在每个传入邮件中删除文本。
我的规则设置正确，但我的脚本是错误的。
Sub mails(MyMail As MailItem)
Dim newMail As MailItem
Set newMail = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items.GetFirst
newMail.HTMLBody = Replace(newMail.HTMLBody, "Not Internal", "")
newMail.Save
End Sub
尝试：
Sub mails(MyMail As MailItem)
With MyMail
If Instr(1, .HTMLBody, "Not Internal") > 0 Then
.HTMLBody = Replace(.HTMLBody, "Not Internal", "")
.Save
End If
End With
End Sub
您的原始代码创建了newMail作为默认收件箱中第一项的副本，并修改了该电子邮件。我的版本通过规则处理电子邮件传递给它的电子邮件。请注意，只有在主体包含"不内部"字符串的情况下，仅修改并保存电子邮件。
将电子邮件的一部分转换为VBA分配语句：第1部分
首先警告：
大部分代码是我为我写的。评论是这样，我可以在编写12或24个月后需要修改该代码时就可以理解代码。我只添加了一些评论来帮助您。尝试了解我的代码的作用，但如有必要，请提出问题。
此系统正在进行中。当我不完全了解自己正在尝试的范围时，这是我的发展的典型特征。我使用现有代码创建简单的东西，并逐渐改善它，因为我对需求的理解有所改善。反复更新代码最终意味着它太混乱了，无法再次更新。然后，我为下一个开发周期进行了重新设计和重写。我不知道此代码中有任何错误，但是将有我从未测试过的方案。让我知道任何问题。如有必要，请使用我的个人资料中的电子邮件地址向我发送问题的全部详细信息。
完成了这个答案后，我可以看到您有很多理解。尽管Macros做了所有困难的事情，但了解他们在做什么，为什么不容易。通过此答案慢慢进行工作，请确保您在进行下一个步骤之前了解每个步骤。祝你好运。
第一步是发现VBA宏的这些电子邮件中的一张。这是我使用的例程：
Option Explicit
Public Sub InvestigateEmailsFile()
' Outputs properties of selected emails to file "InvestigateEmails.txt"
' on the desktop.
' ??????? No record of when originally coded
' 22Oct16 Create separate version with output to file rather than
' Immediate Window.
' 15Jan19 Previously, control characters were represented by {cr}, {lf}
' and {tb}. There were replaced by ‹cr›, ‹lf› and ‹tb› on the
' assumption that these special characters would never appear
' in an email. "‹" is u2039 and "›" is u203A
' 4Feb19 Previous version had tidied text itself because OutLongTextRtn
' did not tidy text. Amended OutLongTextRtn to use TidyTextForDspl
' Technique for locating desktop from answer by Kyle:
' http://stackoverflow.com/a/17551579/973283
' Needs reference to "Microsoft Scripting Runtime"
Dim Exp As Explorer
Dim FileBody As String
Dim fso As FileSystemObject
Dim InxA As Long
Dim ItemCrnt As MailItem
Dim Path As String
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop")
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
FileBody = ""
For Each ItemCrnt In Exp.Selection
If FileBody <> "" Then
FileBody = FileBody & vbLf
End If
With ItemCrnt
FileBody = FileBody & "From (Sender): " & .Sender
FileBody = FileBody & vbLf & "From (Sender name): " & .SenderName
FileBody = FileBody & vbLf & "From (Sender email address): " & _
.SenderEmailAddress
FileBody = FileBody & vbLf & "Subject: " & CStr(.Subject)
FileBody = FileBody & vbLf & "Received: " & Format(.ReceivedTime, "dmmmyy hh:mm:ss")
If .Attachments.Count = 0 Then
FileBody = FileBody & vbLf & "No attachments"
Else
FileBody = FileBody & vbLf & "Attachments:"
FileBody = FileBody & vbLf & "No.|Type|Path|Filename|DisplayName|"
For InxA = 1 To .Attachments.Count
With .Attachments(InxA)
FileBody = FileBody & vbLf & InxA & "|"
Select Case .Type
Case olByValue
FileBody = FileBody & "Val"
Case olEmbeddeditem
FileBody = FileBody & "Ebd"
Case olByReference
FileBody = FileBody & "Ref"
Case olOLE
FileBody = FileBody & "OLE"
Case Else
FileBody = FileBody & "Unk"
End Select
' Not all types have all properties. This code handles
' those missing properties of which I am aware. However,
' I have never found an attachment of type Reference or OLE.
' Additional code may be required for them.
Select Case .Type
Case olEmbeddeditem
FileBody = FileBody & "|"
Case Else
FileBody = FileBody & "|" & .Pathname
End Select
FileBody = FileBody & "|" & .Filename
FileBody = FileBody & "|" & .DisplayName & "|"
End With
Next
End If ' .Attachments.Count = 0
Call OutLongTextRtn(FileBody, "Text: ", .Body)
Call OutLongTextRtn(FileBody, "Html: ", .HtmlBody)
FileBody = FileBody & vbLf & "--------------------------"
End With
Next
End If
Call PutTextFileUtf8NoBom(Path & "InvestigateEmails.txt", FileBody)
End Sub
Public 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.
‘ ??????? Date originally coded not recorded.
' 15Jan19 Added "|" at start and end of lines to make it clearer if
' whitespace added by this routine or in original TextIn
' 3Feb19 Discovered I had two versions of OutLongText. Renamed this version to
' indicate it returned a formatted string.
' 4Feb19 Previous version relied on the caller tidying text for display. This
' version expects TextIn to be untidied and uses TidyTextForDspl to tidy
' the text and then creates TextOut from its output.
If TextIn = "" Then
' Nothing to do
Exit Sub
End If
Const LenLineMax As Long = 100
'Dim LenLineCrnt As Long
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
'Dim TextInPart As String
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
Public Sub PutTextFileUtf8NoBom(ByVal PathFileName As String, ByVal FileBody As String)
' Outputs FileBody as a text file named PathFileName using
' UTF-8 encoding without leading BOM
' Needs reference to "Microsoft ActiveX Data Objects n.n Library"
' Addition to original code says version 2.5. Tested with version 6.1.
' 1Nov16 Copied from http://stackoverflow.com/a/4461250/973283
' but replaced literals with parameters.
' 15Aug17 Discovered routine was adding an LF to the end of the file.
' Added code to discard that LF.
' 11Oct17 Posted to StackOverflow
' 9Aug18 Comment from rellampec suggested removal of adWriteLine from
' WriteTest statement would avoid adding LF.
' 30Sep18 Amended routine to remove adWriteLine from WriteTest statement
' and code to remove LF from file. Successfully tested new version.
' References: http://stackoverflow.com/a/4461250/973283
' https://www.w3schools.com/asp/ado_ref_stream.asp
Dim BinaryStream As Object
Dim UTFStream As Object
Set UTFStream = CreateObject("adodb.stream")
UTFStream.Type = adTypeText
UTFStream.Mode = adModeReadWrite
UTFStream.Charset = "UTF-8"
UTFStream.Open
UTFStream.WriteText FileBody
UTFStream.Position = 3 'skip BOM
Set BinaryStream = CreateObject("adodb.stream")
BinaryStream.Type = adTypeBinary
BinaryStream.Mode = adModeReadWrite
BinaryStream.Open
UTFStream.CopyTo BinaryStream
UTFStream.Flush
UTFStream.Close
Set UTFStream = Nothing
BinaryStream.SaveToFile PathFileName, adSaveCreateOverWrite
BinaryStream.Flush
BinaryStream.Close
Set BinaryStream = Nothing
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 ‹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›
' 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
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)
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>x
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) * (1 - NumWsChar) + 1 + Len(NumWsChar)
Loop
Next
' Restore any single spaces
RetnVal = Replace(RetnVal, "‹" & WsCharDspl(0) & "›", " ")
TidyTextForDspl = RetnVal
End Function
上面的代码需要引用" Microsoft脚本运行时"one_answers" Microsoft ActiveX数据对象N.N库"。
对于我的一封电子邮件之一，上面的代码在我的桌面上创建一个名为" discoundemails.txt"的文件：
From (Sender): Zopa
From (Sender name): Zopa
From (Sender email address): zopa@mail.zopa.com
Subject: Jane, your weekly Zopa update
Received: 1Mar19 16:30:49
No attachments
Text: |The latest news from Zopa‹crlf›|
| <http://click.mail.zopa.com/?qs=df1dd45fb22f0a80e44887f2afb89fa999010ffe37c4dffba1b431d565441dc586e|
|95525d2f44408471d2d3f3d36fcf89cca0b23e2b9ff84> ‹tb› ‹crlf›|
|Can't see images?‹2 s›View in browser <http://view.mail.zopa.com/?qs=4fd1698978f7849d57bb369504b2222|
|ec6a4dab29397ae38367d7cb6cda466891c948bfdca1b6e9a91fdf2f03d994985087240cc3ba05080cb96697ecdafef5faae|
|24843efc1e3649f6b94139653b26d> ‹crlf›|
: : : :
|change your Contact Preferences.‹crlf›|
| <http://click.mail.zopa.com/open.aspx?ffcb10-fefa1375756d04-fe53157770600d7a7113-fe3e15707564047b71|
|1773-ff62107470-fe671673766d017d7516-ff9a1574> |
Html: |<!doctype html><html xmlns="http://www.w3.org/1999/xhtml" xmlns:v="urn:schemas-microsoft-com:vml" xm|
|lns:o="urn:schemas-microsoft-com:office:office"><head> <title>Zopa</title> <!--[if !mso]><!-- --> <m|
|eta http-equiv="X-UA-Compatible" content="IE=edge"> <!--<![endif]-->‹2 s›<meta name="viewport" conte|
|nt="width=device-width,initial-scale=1"> ‹crlf›|
|<style type="text/css"> #outlook a { padding: 0; } .ReadMsgBody { width: 100%; } .ExternalClass { wi|
|dth: 100%; } .ExternalClass * { line-height: 100%; } body { margin: 0; padding: 0; -webkit-text-size|
: : : :
您可以看到，此文件列出了包括文本和HTML主体在内的最有趣的属性。如果需要查看，我会添加额外的属性。文本和HTML的身体完全按照Outlook的持有，除了我用字符串代替了控制字符的字符串具有"×CRLF›"。这使我可以准确了解VBA程序是否正在处理电子邮件主体。
在此电子邮件末尾附近是发件人在所有电子邮件中包含的文本块。我想这是一种块，您想从电子邮件中删除。
将上述代码复制到Outlook模块。选择您希望处理的一封电子邮件之一，然后运行宏" devendemailsfile（）"。您应该在桌面上有一个名为" Explorer.txt"的文件。使用您喜欢的文本编辑器打开该文件，您应该看到上面的内容。
将电子邮件的一部分转换为VBA分配语句：第2部分
在第1部分的末尾，您应该在桌面上有一个文件，其中包含您要修改的电子邮件之一的HTML主体。
下一步是创建一个名为"身体"的工作表的XLSM工作簿。扩展列" A"one_answers" B"，因此" C"是可见的。使" A"列比" B"较宽。我发现将工作表格式化为字体快递（New）和9号。
您现在需要在工作簿中创建一个模块，然后将此代码复制到其中：
Option Explicit
Sub ConvertBodyFromExplorerToVBA()
' Column A of worksheet "Body" contains all or part of the
' body of an email as output to file "Explorer.txt".
' On exit, the data in column A has been converted to
' VBA format in column B.
' 17Jan19 Coded as part of FormatBodyAsVBA V01.xlsm
' 10Mar19 Adjusted for the new format of "Explorer.txt"
' Added code to handle output that requires more
' continuation lines than allowed for VBA
Const MaxContLines As Long = 24 ' Maximum number of continuation lines per VBA statement
Const MaxLineLen As Long = 70 ' Normal maximum length of a line of the VBA string expression
Const MinPartLitLen As Long = 5 ' If a literal is split over two lines, neither part may be
' less than MinPartStrLen characters.
Dim BodyIn As String ' The string to be converted to a VBA string expression
Dim BodyPartsOut As New Collection ' Each element is a part of the VBA string expression
' Parts are "xxx" or vbCr or VbLf or so on
Dim CtrlCharType As String ' s, cr, lf, crlf or nbs
Dim CtrlCharVba As String ' VBA equivalent of s, cr, lf, crlf or nbs
Dim InxB As Long ' Inxex into BodyPartsOut
'Dim LenNextPart As Long
Dim LenOver As Long ' If a literal is to be split over two lines,
' the length for the next line
Dim LenThisLine As Long ' If a literal is to be split over two lines,
' the length for the current line
Dim LineCrnt As String ' Line imported from column A or
' line being built ready to be added to column B
Dim LenMax As Long ' Maximum length of string that can be added to LineCrnt
Dim NumContLines ' Number of contuation lines for current string expression
Dim NumRpts As Long ' # from ‹# xx›
Dim NumVariables As Long ' Number of variables required to hold output string expression
Dim PosInCrnt As Long ' Everything before position PosInCrnt of BodyIn
' has been output to BodyPartsOut
Dim PosInNext As Long ' Start of next control character or end of BodyIn
Dim PosV As Long ' Position of vertical bar within LineCrnt
Dim RowInCrnt As Long ' Used to control building of
Dim RowInLast As Long ' / BodyIn from input lines
Dim RowOutCrnt As Long ' Row of column B for LineCrnt
Dim UnitCrnt As String ' Holds a string literal while it is being split
' over multiple lines.
With Worksheets("Body")
.Columns(2).Clear
' The source within the text file will be of the form:
' Text: |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx|
' |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx|
' |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx|
' Html: |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx|
' |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx|
' |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx|
'
' Part of either a text body or an html body will have been copied to
' column 1 of worksheet "Body". Do not include any part of "Text:" or
' "Html:" as this will confuse the code that removes the start and end
' of each line.
' This For loop removes the leading " |" and trailing "|" from each
' line and joins the text between the vertical lines into a single string.
BodyIn = ""
RowInLast = .Cells(Rows.Count, "A").End(xlUp).Row
For RowInCrnt = 1 To RowInLast
LineCrnt = .Cells(RowInCrnt, "A").Value
If Right$(LineCrnt, 1) = "|" Then
' Remove trailing "|"
LineCrnt = Mid$(LineCrnt, 1, Len(LineCrnt) - 1)
End If
Do While Left$(LineCrnt, 1) = " "
' Remove leading space
LineCrnt = Mid$(LineCrnt, 2)
Loop
If Left$(LineCrnt, 1) = "|" Then
' Remove leading "|"
LineCrnt = Mid$(LineCrnt, 2)
End If
BodyIn = BodyIn & LineCrnt
Next
End With
' Display BodyIn as a diagnostic aid.
Debug.Print "[" & Replace(BodyIn, "lf›", "lf›" & vbLf) & "]"
'Debug.Assert False
' * This Do loop converts BodyIn into the units of a VBA string expression
' and stores them in collection BodyPartsOut. These units are "xxxx",
' vbCr, vbLf, vbCrLf, vbTab, Chr$(160) and String(#, "x").
' * The input is ... xxxxxx‹# yy›xxxxxx‹yy›xxxxxx‹# yy› ...
' * This loop puts speech marks around each string of xs to create a string
' literal and decodes each ‹...› and creates one or more of the other
' units as appropriate.
PosInCrnt = 1
Do While PosInCrnt <= Len(BodyIn)
'Find next control character if any
PosInNext = InStr(PosInCrnt, BodyIn, "‹")
If PosInNext = 0 Then
' No [more] control characters in BodyIn.
'Debug.Assert False
PosInNext = Len(BodyIn) + 1
End If
If PosInCrnt = PosInNext Then
' Next character of BodyIn is the start of control character
PosInCrnt = PosInCrnt + 1
If IsNumeric(Mid$(BodyIn, PosInCrnt, 1)) Then
' Control string is of the form: ‹# xx› where
' # is the number of repeats of control character xx
PosInNext = InStr(PosInCrnt, BodyIn, " ")
NumRpts = Mid$(BodyIn, PosInCrnt, PosInNext - PosInCrnt)
PosInCrnt = PosInNext + 1
Else
' Control string is of the form: ‹xx› where xx identifies a control character
NumRpts = 1
PosInCrnt = PosInNext + 1
End If
PosInNext = InStr(PosInCrnt, BodyIn, "›")
CtrlCharType = Mid$(BodyIn, PosInCrnt, PosInNext - PosInCrnt)
PosInCrnt = PosInNext + 1
Select Case CtrlCharType
Case "s"
' CtrlCharVba not used for space
Case "crlf"
CtrlCharVba = "vbCrLf"
Case "tb"
CtrlCharVba = "vbTab"
Case "cr"
CtrlCharVba = "vbCr"
Case "lf"
CtrlCharVba = "vbLf"
Case "nbs"
CtrlCharVba = "Chr$(160)"
Case Else
Debug.Assert False ' Error. Unknown control character type
End Select
If NumRpts = 1 Then
' Note: no single spaces
BodyPartsOut.Add CtrlCharVba
ElseIf CtrlCharType = "s" Then
' Single, repeating space
BodyPartsOut.Add "Space(" & NumRpts & ")"
ElseIf CtrlCharType <> "crlf" Then
' Single, repeating control character
BodyPartsOut.Add "String(" & NumRpts & ", " & CtrlCharVba & ")"
Else
' Double, repeating control character
Do While NumRpts > 0
BodyPartsOut.Add CtrlCharVba
NumRpts = NumRpts - 1
Loop
End If
Else
' Convert display characters PosInCrnt to PosInNext of BodyIn to a string literal
BodyPartsOut.Add """" & Mid$(BodyIn, PosInCrnt, PosInNext - PosInCrnt) & """"
PosInCrnt = PosInNext
End If
Loop
' Display the elements of BodyPartsOut as a diagnostic aid.
Debug.Print
Debug.Print "[";
LineCrnt = ""
For InxB = 1 To BodyPartsOut.Count
If InxB > 1 Then
LineCrnt = LineCrnt & " & "
End If
If Len(LineCrnt) + 3 + Len(BodyPartsOut(InxB)) > MaxLineLen Then
Debug.Print LineCrnt & " _"
LineCrnt = ""
End If
LineCrnt = LineCrnt & BodyPartsOut(InxB)
Next
Debug.Print LineCrnt & "]"
'Debug.Assert False
Debug.Print
RowOutCrnt = 1
NumVariables = 1
NumContLines = 0
LineCrnt = " Text1 = "
With Worksheets("Body")
' This For loop converts the seperate units in BodyPartsOut into a string
' expression by places " & " between each unit and outputting the result
' to column B of worksheet "Body". It also cuts the entire string
' expression into lines of about MaxLineLen characters and adds " _" at
' the end of each line except the last.
For InxB = 1 To BodyPartsOut.Count
If InxB > 1 Then
' " & " needed before every unit except the first
LineCrnt = LineCrnt & " & "
End If
' The IIf below returns 2 (the length of " _") except for the last unit
' for which it returns 0. This allows for a line continuation if necessary.
If Len(LineCrnt) + IIf(InxB = BodyPartsOut.Count, 0, 4) + _
Len(BodyPartsOut(InxB)) <= MaxLineLen Then
' Can fit the whole of the next body part onto the next line
'Debug.Assert False
LineCrnt = LineCrnt & BodyPartsOut(InxB)
'Debug.Print "LineCrnt [" & LineCrnt & "]"
ElseIf Left$(BodyPartsOut(InxB), 1) <> """" Then
' Unit is not a literal so cannot be split. Place on following line
'Debug.Assert False
If NumContLines = MaxContLines Then
'Debug.Assert False
LineCrnt = Mid$(LineCrnt, 1, Len(LineCrnt) - 2) ' Remove concatenation
.Cells(RowOutCrnt, "B").Value = LineCrnt
' Start new variable
NumVariables = NumVariables + 1
NumContLines = 0
LineCrnt = " Text" & NumVariables & " = "
Else
'Debug.Assert False
.Cells(RowOutCrnt, "B").Value = LineCrnt & "_"
NumContLines = NumContLines + 1
LineCrnt = Space(10)
End If
Debug.Print "Row " & PadL(RowOutCrnt, 2) & " [" & .Cells(RowOutCrnt, "B").Value & "]"
RowOutCrnt = RowOutCrnt + 1
LineCrnt = LineCrnt & BodyPartsOut(InxB)
'Debug.Print "LineCrnt [" & LineCrnt & "]"
Else
'Debug.Assert False
' Unit is a literal which can be split over two or more lines
' A collection element cannot be amended so copy to variable
' without speech marks.
UnitCrnt = Mid$(BodyPartsOut(InxB), 2, Len(BodyPartsOut(InxB)) - 2)
Do While UnitCrnt <> ""
'Debug.Assert False
LenThisLine = MaxLineLen - Len(LineCrnt) - 4 ' 4 for " & _"
LenOver = Len(UnitCrnt) - LenThisLine
If LenOver < 0 Then
LenOver = 0
End If
If LenOver = 0 Then
' Can fit remainder of UnitCrnt on current line
'Debug.Assert False
' Double any speech marks within literal
LineCrnt = LineCrnt & """" & Replace(UnitCrnt, """", """""") & """"
'Debug.Print "LineCrnt [" & LineCrnt & "]"
Exit Do
ElseIf LenThisLine < MinPartLitLen Then
' No room for part of literal on current line so settle for short line
Debug.Assert False
If NumContLines = MaxContLines Then
Debug.Assert False
LineCrnt = Mid$(LineCrnt, 1, Len(LineCrnt) - 2) ' Remove concatenation
.Cells(RowOutCrnt, "B").Value = LineCrnt
' Start new variable
NumVariables = NumVariables + 1
NumContLines = 0
LineCrnt = " Text" & NumVariables & " = "
Else
Debug.Assert False
.Cells(RowOutCrnt, "B").Value = LineCrnt & "_"
NumContLines = NumContLines + 1
LineCrnt = Space(10)
End If
Debug.Print "Row " & PadL(RowOutCrnt, 2) & " [" & .Cells(RowOutCrnt, "B").Value & "]"
RowOutCrnt = RowOutCrnt + 1
LineCrnt = LineCrnt & BodyPartsOut(InxB)
' Loop to fit all or part of UnitCrnt onto next line
ElseIf LenOver < MinPartLitLen Then
' Left over portion of literal too short to be split off.
' Settle for overlength current line
Debug.Assert False
LineCrnt = LineCrnt & """" & Replace(UnitCrnt, """", """""") & """ &"
If NumContLines = MaxContLines Then
Debug.Assert False
LineCrnt = Mid$(LineCrnt, 1, Len(LineCrnt) - 2) ' Remove concatenation
.Cells(RowOutCrnt, "B").Value = LineCrnt
' Start new variable
NumVariables = NumVariables + 1
NumContLines = 0
LineCrnt = " Text" & NumVariables & " = "
Else
Debug.Assert False
.Cells(RowOutCrnt, "B").Value = LineCrnt & "_"
NumContLines = NumContLines + 1
LineCrnt = Space(10)
End If
Debug.Print "Row " & PadL(RowOutCrnt, 2) & " [" & .Cells(RowOutCrnt, "B").Value & "]"
RowOutCrnt = RowOutCrnt + 1
Else
' UnitCrnt can be split. Fit what can onto current line
'Debug.Assert False
LineCrnt = LineCrnt & """" & _
Replace(Left$(UnitCrnt, LenThisLine), """", """""") & """ & "
If NumContLines = MaxContLines Then
'Debug.Assert False
LineCrnt = Mid$(LineCrnt, 1, Len(LineCrnt) - 2) ' Remove concatenation
.Cells(RowOutCrnt, "B").Value = LineCrnt
' Start new variable
NumVariables = NumVariables + 1
NumContLines = 0
LineCrnt = " Text" & NumVariables & " = "
Else
'Debug.Assert False
.Cells(RowOutCrnt, "B").Value = LineCrnt & "_"
NumContLines = NumContLines + 1
LineCrnt = Space(10)
End If
Debug.Print "Row " & PadL(RowOutCrnt, 2) & " [" & .Cells(RowOutCrnt, "B").Value & "]"
UnitCrnt = Mid$(UnitCrnt, LenThisLine + 1)
RowOutCrnt = RowOutCrnt + 1
' Loop to fit all or part of UnitCrnt onto next line
End If ' List of alternative splitting techniques for handling overlength unit
Loop ' Until all of UnitCrnt has been output
End If ' UnitCrnt fits onto current line or list of alternative choices
Next InxB
If LineCrnt <> "" Then
.Cells(RowOutCrnt, "B").Value = LineCrnt
Debug.Print "Row " & RowOutCrnt & " [" & .Cells(RowOutCrnt, "B").Value & "]"
End If
End With
End Sub
Sub TestConvertOutput()
Dim Text1 As String
Dim Text2 As String
Dim TextToBeRemoved As String
TextToBeRemoved = Text1 & Text2
Debug.Print TidyTextForDspl(TextToBeRemoved)
End Sub
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with leading PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Sep15 Coded
' 20Dec15 Added code so overlength strings are not truncated
' 10Jun16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadL = Str
Else
PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
End If
End Function
Outlook代码包括宏TidyTextForDspl。您也需要在Excel模块中进行此宏。
我怀疑Outlook代码是否会给您带来任何问题，因为我已经使用了一段时间了。我唯一关心的是，我忘记了包括与宏InvestigateEmailsFile不在同一模块中的我的图书馆例程之一。此Excel代码是实验性的。我已经在HTML上测试了它，我希望比您更复杂。该HTML转换为超过VBA限制的字符串表达式。这个周末，我已经扩展到代码以避免该限制。
现在返回" Explorer.txt"。选择并复制要删除的整个块。（我将在下面解释这一点。）切换到工作簿并将其粘贴到工作表"身体"的单元格A1中。在我的示例电子邮件中，" A"列看起来如下：
<div style="font-family:Verdana;font-size:12px;font-weight:400;line-height:16px;text-align:lef|
|t;color:#ABABAB;">‹crlf›|
|‹16 s›Zopa Limited is authorised and regulated by the Financial Conduct Authority, and entered on th|
|e Financial Services Register (<span style="color:#00B9A7;">718925</span>). Zopa Bank Limited is aut|
|horised by the Prudential Regulation Authority and regulated by the Financial Conduct Authority and |
|the Prudential Regulation Authority, and entered on the Financial Services Register (<span style="co|
|lor:#00B9A7;">800542</span>). Zopa Limited (<span style="color:#00B9A7;">05197592</span>) and Zopa B|
|ank Limited (<span style="color:#00B9A7;">10627575</span>) are both incorporated in England & Wa|
|les and have their registered office at: 1st Floor, Cottons Centre, Tooley Street, London, SE1 2QG.<|
|br>‹crlf›|
|‹16 s›<br>‹crlf›|
|‹16 s›© Zopa Bank Limited 2019 All rights reserved. 'Zopa' is a trademark of Zopa Bank Limited.|
|<br>‹crlf›|
|‹16 s›<br>‹crlf›|
|‹16 s›Zopa is a member of Cifas – the UK’s leading anti-fraud association, and we are re|
|gistered with the Office of the Information Commissioner (<span style="color:#00B9A7;">ZA275984</spa|
|n>, <span style="color:#00B9A7;">Z8797078</span>).<br>‹crlf›|
|‹16 s›<br>‹crlf›|
|‹16 s›No longer want to receive our emails? <a‹2 s›href="http://click.mail.zopa.com/?qs=df1dd45fb22f|
|0a804e99ede07e73c95c826908dfc9aef47f93c598c0c6537648c2c346408fab877afa32022afc1a846a3060560073066676|
|d72d0a4720039df6" style="color: #ffffff; font-weight: 700; text-decoration: none;">Unsubscribe</a> o|
|r sign into your <a‹2 s›href="http://click.mail.zopa.com/?qs=df1dd45fb22f0a80c21dc52c7c6968eb3af863f|
|9656119ff373444e56f12bbc5c50c416ecbcd8e2c0192ac31983d91b06478e0f60261102d" style="color: #ffffff; fo|
|nt-weight: 700; text-decoration: none;">Zopa Account</a> to change your Contact Preferences.</div>
我通过搜索" HTML："然后" Zopa Limited获得授权"来找到此块。您需要搜索要删除的文本的开始。接下来是困难的步骤。您需要标识要删除的整个块。
如果您查看我的示例，则块开始<div style="font并结束</div>。您说要删除的文本是有色的。注意，<div>启动标签端color:#ABABAB的样式属性。您几乎可以肯定会在要删除的块开始时有类似的东西，因为这是文本的颜色。您需要删除整个块；不仅是文本，而且是该文本周围的HTML包络。该信封可能是<div>到</div>，但还有许多其他可能的信封。对于我的系统的未来版本，我计划选择文本，并让宏标识包含该文本的块的开始和结尾。但是有了当前版本，您必须标识块。
正如我已经说过的，您需要选择整个块并将其复制并粘贴到工作表"身体"的A列。请注意，我只选择了块，因此在上面的示例中，A列的第一行和最后一行很短。
so" Explorer.txt"包含您希望删除文本块的电子邮件的人类可读格式的属性。您已经复制了该块，包括其HTML信封为工作表"正文" A列。
运行宏" convertbodyfromexplorertovba（）"
我已经在此宏和Debug.Assert False语句中留下了诊断代码，因此您可以查看直接窗口的诊断输出。完成输出后，单击[F5]。宏完成后，B列应该看起来像：
Text1 = "<div style=""font-family:Verdana;font-size:12px;font-weig" & _
"ht:400;line-height:16px;text-align:left;color:#ABABAB;"">" & _
vbCrLf & Space(16) & "Zopa Limited is authorised and regu" & _
"lated by the Financial Conduct Authority, and entered on" & _
" the Financial Services Register (<span style=""color:#00" & _
"B9A7;"">718925</span>). Zopa Bank Limited is authorised b" & _
"y the Prudential Regulation Authority and regulated by t" & _
"he Financial Conduct Authority and the Prudential Regula" & _
"tion Authority, and entered on the Financial Services Re" & _
"gister (<span style=""color:#00B9A7;"">800542</span>). Zop" & _
"a Limited (<span style=""color:#00B9A7;"">05197592</span>)" & _
" and Zopa Bank Limited (<span style=""color:#00B9A7;"">106" & _
"27575</span>) are both incorporated in England & Wal" & _
"es and have their registered office at: 1st Floor, Cotto" & _
"ns Centre, Tooley Street, London, SE1 2QG.<br>" & _
vbCrLf & Space(16) & "<br>" & vbCrLf & Space(16) & "©" & _
"; Zopa Bank Limited 2019 All rights reserved. 'Zopa' is " & _
"a trademark of Zopa Bank Limited.<br>" & vbCrLf & _
Space(16) & "<br>" & vbCrLf & Space(16) & "Zopa is a memb" & _
"er of Cifas – the UK’s leading anti-fraud as" & _
"sociation, and we are registered with the Office of the " & _
"Information Commissioner (<span style=""color:#00B9A7;"">Z" & _
"A275984</span>, <span style=""color:#00B9A7;"">Z8797078</s" & _
"pan>).<br>" & vbCrLf & Space(16) & "<br>" & vbCrLf & _
Space(16) & "No longer want to receive our emails? <a"
Text2 = Space(2) & "href=""http://click.mail.zopa.com/?qs=df1dd45f" & _
"b22f0a804e99ede07e73c95c826908dfc9aef47f93c598c0c6537648" & _
"c2c346408fab877afa32022afc1a846a3060560073066676d72d0a47" & _
"20039df6"" style=""color: #ffffff; font-weight: 700; text-" & _
"decoration: none;"">Unsubscribe</a> or sign into your <a" & _
Space(2) & "href=""http://click.mail.zopa.com/?qs=df1dd45f" & _
"b22f0a80c21dc52c7c6968eb3af863f9656119ff373444e56f12bbc5" & _
"c50c416ecbcd8e2c0192ac31983d91b06478e0f60261102d"" style=" & _
"""color: #ffffff; font-weight: 700; text-decoration: none" & _
";"">Zopa Account</a> to change your Contact Preferences.<" & _
"/div>"
我的文本块很长，输出超过了24个连续行的VBA限制，因此列B中有两个分配语句。您可能只需要一个分配语句，或者您可能需要更多。
宏已将A列中的文本转换为B列中的VBA分配语句，准备复制到您的宏。
要测试输出，请选择B列中的所有文本。切换到VBA编辑器并找到Macro TestConvertOutput。将文本从B列粘贴到Dim TextToBeRemoved As String和TextToBeRemoved = Text1 & Text2之间的差距中。应该没有语法错误。如果您不需要Text2或需要Text3，请根据需要对例程进行修改。如果运行宏TestConvertOutput，则应将要删除的块输出任何错误。
宏TestConvertOutput中的语句是宏mails所需的语句。TextToBeRemoved是替换"非内部"的值。