将电子邮件的一部分转换为 VBA 作业语句：第 2 部分
在第 1 部分结束时，您的桌面上应该有一个文件，其中包含您希望修改的一封电子邮件的 Html 正文。
下一步是创建一个 XLSM 工作簿，其中包含一个名为“Body”的工作表。展开列“A”和“B”，使“C”可见。使“A”列比“B”稍宽。我发现将工作表的格式设置为字体 Courier 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”。选择并复制要删除的整个块。 （我将在下面解释。）切换到工作簿并粘贴到工作表“Body”的单元格 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 列的第一行和最后一行都很短。
因此，“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 编辑器并找到宏 TestConvertOutput。将 B 列中的文本粘贴到 Dim TextToBeRemoved As String 和 TextToBeRemoved = Text1 & Text2 之间的空白处。应该没有语法错误。如果不需要 Text2 或需要 Text3，请根据需要修改例程。如果您运行宏TestConvertOutput，它应该将要删除的块输出到立即窗口，并显示任何错误。
宏TestConvertOutput 中的语句是宏mails 需要的语句。 TextToBeRemoved 是替换“非内部”的值。