我正在尝试在运行的每个传入邮件中编写脚本，如果文本匹配，则应自动删除该文本。
通常情况下，Outlook脚本修改是隐藏的，但我将其打开，以便在创建规则时可以看到脚本部分。我的规则设置正确，但是脚本错误。我该如何解决？甚至有可能吗？
我正在编写以下脚本，但是它无法正常工作，并且无法调试以查看问题所在。我应该在这里解决什么？
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
答案 0 :(得分：1)
尝试：
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作为默认收件箱中第一项的副本，并修改了该电子邮件。我的版本处理该规则传递给它的电子邮件。请注意，只有在正文中包含字符串“ Not Internal”时，才修改并保存电子邮件。
答案 1 :(得分：0)
将电子邮件的一部分转换为VBA分配语句：第1部分
首先警告：
大多数代码是我为我编写的。这些注释是为了让我在编写代码后12或24个月需要修改代码时可以理解代码。我仅添加了一些评论来帮助您。尝试了解我的代码的作用，但在必要时提出问题。
此系统正在开发中。当我不完全了解自己尝试的范围时，这是我的发展中的典型代表。我使用现有代码创建一些简单的内容，并随着对需求的了解逐渐提高。反复更新代码最终意味着它太乱了，无法再次更新。然后，我重新设计并重写以准备进行下一个开发周期。我不知道此代码中的任何错误，但有些情况我从未测试过。让我知道任何问题。如有必要，请使用我的个人资料中的电子邮件地址向我发送问题的完整详细信息。
完成此答案后，我可以看到您有很多需要理解的地方。尽管宏可以处理所有困难的事情，但要了解它们在做什么以及为什么这样做并不容易。慢慢解决此问题，以确保您理解每个步骤，然后再进行下一步。祝好运。
第一步是发现这些电子邮件对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脚本运行时”和“ Microsoft ActiveX数据对象n.n库”。
对于我的一封电子邮件，以上代码在我的桌面上创建了一个名为“ InvestigateEmails.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模块。选择您要处理的电子邮件之一，然后运行宏“ InvestigateEmailsFile（）”。您应该在桌面上有一个名为“ Explorer.txt”的文件。使用您喜欢的文本编辑器打开该文件，您应该会看到类似上面的内容。
答案 2 :(得分：0)
将电子邮件的一部分转换为VBA分配语句：第2部分
在第1部分末尾，您应该在桌面上有一个文件，其中包含您要修改的一封电子邮件的HTML正文。
下一步是使用一个名为“ Body”的工作表创建XLSM工作簿。展开列“ 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>，但还有很多其他可能的信封。对于我的系统的未来版本，我计划选择文本并有一个宏来标识包含该文本的块的开始和结束。但是在当前版本中，您必须标识该块。
正如我已经说过的，您需要选择整个块并将其复制并粘贴到工作表“ Body”的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是替换“ Not Internal”的值。