Vba 删除收到的电子邮件中的文本
我正在尝试删除每个传入邮件中的文本 我的规则设置正确，但我的脚本为false 子邮件邮件作为邮件项 将新邮件设置为邮件项 设置newMail=Application.GetNamespaceMAPI.GetDefaultFolderolFolderInbox.Items.GetFirst newMail.HTMLBody=ReplacenewMail.HTMLBody，非内部， 新邮件，保存 端接头 尝试： 您的原始代码将newMail创建为默认收件箱中第一个项目的副本，并修改了该电子邮件。我的版本处理规则传递给它的电子邮件。请注意，只有在正文包含字符串而非内部字符串时，才会修改和保存电子邮件 将电子邮件的一部分转换为VBA分配语句：第1部分 首先是警告： 这段代码大部分是我为自己写的。当我在写代码12或24个月后需要修改代码时，我可以理解这些注释。我只添加了一些评论来帮助您。试着理解我的代码的功能，但如有必要，可以提问 该系统正在进行中。当我不完全理解我尝试的范围时，这是我的发展的典型。我使用现有代码创建一些简单的东西，并随着我对需求的理解的提高而逐渐改进。反复更新代码最终意味着代码太乱，无法再次更新。然后我重新设计和重写，为下一个开发周期做好准备。我不知道这段代码中有任何错误，但会有一些我从未测试过的场景。有什么问题请告诉我。如有必要，请使用我个人资料中的电子邮件地址向我发送问题的完整详细信息 完成这个答案后，我可以看出有很多东西需要你去理解。尽管宏做了所有困难的事情，但理解它们在做什么以及为什么做并不容易。慢慢地完成这个答案，确保你在进入下一步之前理解了每一步。祝你好运 第一步是发现其中一封电子邮件在VBA宏中的外观。这是我使用的例行程序：Vba 删除收到的电子邮件中的文本,vba,outlook,Vba,Outlook,我正在尝试删除每个传入邮件中的文本 我的规则设置正确，但我的脚本为false 子邮件邮件作为邮件项 将新邮件设置为邮件项 设置newMail=Application.GetNamespaceMAPI.GetDefaultFolderolFolderInbox.Items.GetFirst newMail.HTMLBody=ReplacenewMail.HTMLBody，非内部， 新邮件，保存 端接头 尝试： 您的原始代码将newMail创建为默认收件箱中第一个项目的副本，并修改了该电子邮件。我的
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
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|
: : : :
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
如果你看我的例子，块开始请注意，它不工作没有有用的错误描述。相反，请告诉我您在哪一行中遇到了哪些错误，或者您的代码实际执行了哪些操作，以及您希望它执行的操作。正如我所说的，脚本在backgorund中运行。它没有给出错误，但没有执行预期的操作。您希望不会发生什么？我注意到您正在默认收件箱中创建第一封电子邮件的副本，而忽略了其余的电子邮件。您应该处理作为参数传递的电子邮件。我想要的是，它查看传入的邮件如果不存在内部文本，它应该删除该文本。我不想创建副本，只需处理传入邮件编辑并保存它。它不起作用。htmlbody不是邮件正常编写的部分吗？我不知道为什么，但我会进一步尝试。仍然不工作，我不知道为什么。我正在寻找incom的源代码
是的，它在htmlbody中。有什么方法可以从收到的邮件中删除长html代码吗？完全相同的问题：，我每次都会手动删除，这会导致一段时间，我想自动执行此操作：Let us。我已经删除了我的评论，因为它们在聊天室中都是重复的。我建议你也这样做。
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
<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>
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>"