Delete text in incoming email - vba

Question

I am trying to delete text in each incoming mail.
My rule settings are correct but my script is false.
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

Answer 1

Try:
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
Your original code created newMail as a copy of the first item in the default inbox and amended that email. My version processes the email passed to it by the rule. Note that the email is only amended and saved if the body includes the string "Not Internal".

Answer 2

Converting part of an email to a VBA assignment statement: Part 1
First the warnings:
Most of this code was written by me for me. The comments are so I can understand the code when I need to amend it 12 or 24 months after I wrote it. I have only added a few comments to help you. Try to understand what my code does but ask questions if necessary.
This system is work in progress. It is fairly typical of my developments when I do not fully understand the scope of what I am attempting. I create something simple using existing code and gradually improve it as my understanding of my requirement improves. Repeatedly updating code eventually means it is too messy to be updated again. I then redesign and rewrite ready for the next cycle of development. I do not know of any errors in this code but there will be scenarios I have never tested. Let me know of any problems. If necessary, use the email address in my profile to send me full details of a problem.
Having completed this answer, I can see that there is a lot for you to understand. Although macros do all the difficult stuff, understanding what they are doing and why will not be easy. Work through this answer slowly making sure you understand each step before moving onto the next. Good luck.
The first step is to discover what one of these emails look like to a VBA macro. This is the routine I use:
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
The above code needs references to "Microsoft Scripting Runtime" and "Microsoft ActiveX Data Objects n.n Library".
For one of my emails, the above code creates a file on my desktop named “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|
: : : :
As you can see, this file lists the most interesting properties including the text and Html bodies. I add extra properties if I need to see them. The text and Html bodies are exactly as held by Outlook except I have replaced control characters with strings such has “‹crlf›”. This allows me to understand exactly what a VBA program will see if it is processing an email body.
Near the end of this email is a block of text the sender includes in all their emails. This is sort of block I assume you wish to remove from your emails.
Copy the above code to an Outlook module. Select one of the emails you wish to process and run macro “InvestigateEmailsFile()”. You should have a file on your desktop named “Explorer.txt”. Open that file with your favourite text editor and you should see something like the content above.

Answer 3

Converting part of an email to a VBA assignment statement: Part 2
At the end of Part 1, you should have a file on your desktop containing the Html body of one of the emails you wish to amend.
The next step is to create an XLSM workbook with one worksheet named “Body”. Expand columns “A” and “B” so “C” is just visible. Make column “A” a little wider than “B”. I find it helpful to format the worksheet as font Courier New” and size 9. Don’t worry too much about the size of the columns, you can adjust them later.
You now need to create a module within the workbook and copy this code to it:
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
The Outlook code includes macro TidyTextForDspl. You will need this macro in the Excel module as well.
I doubt if the Outlook code will give you any problems because I have been using that code for some time. My only concern is I have forgotten to include one of my library routines which are not in the same module as macro InvestigateEmailsFile. This Excel code is experimental. I have tested it on Html that I hope is more complicated than yours. That Html converted to a string expression that exceeded a VBA limit. This weekend I have extended to code to avoid that limit.
Now return to “Explorer.txt”. Select and copy the entire block you want to remove. (I will explain this below.) Switch to the workbook and paste into Cell A1 of worksheet “Body”. With my example email, column “A” looks like:
<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>
I found this block by searching for “Html:” and then “Zopa Limited is authorised”. You need to search for the start of the text you want to remove. Next is the difficult step. You need to identify the entire block you want to remove.
If you look at my example, the block starts <div style="font and end </div>. You say the text you want to remove is coloured. Note, the style attribute for the <div> start tag ends color:#ABABAB. You will almost certainly have something similar at the start of the block you want to remove since this is what colours the text. You need to remove the entire block; not just the text but the Html envelope around that text. That envelope will probably be <div> to </div> but there are plenty of other possible envelopes. For a future version of my system, I plan to select the text and have a macro identify the start and end of the block containing that text. But with the current version, you have to identify the block.
As I have already said, you need to select the entire block and copy and paste it to column A of worksheet “Body”. Note, I have only selected the block so in my example above, the first and last lines of column A are short.
So "Explorer.Txt" contains properties, in a human readable format, of the email from you wish to delete a block of text. You have copied that block including its Html envelope to column A of worksheet "Body".
Run macro “ConvertBodyFromExplorerToVBA()”
I have left diagnostic code in this macro and Debug.Assert False statements so you can look at the diagnostic output to the Immediate Window. When you have finished looking at the output, click [F5]. When the macro is finished, column B should look like:
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) & "&copy" & _
"; 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>"
My text block is so long, the output exceeded the VBA limit of 24 continuation lines so there are two assignment statements in Column B. You may only need one assignment statement or you may need more.
The macro has converted the text in column A to VBA assignment statements in column B ready to be copied to your macro.
To test the output, select all the text in column B. Switch to the VBA Editor and find macro TestConvertOutput. Paste the text from column B into the gap between Dim TextToBeRemoved As String and TextToBeRemoved = Text1 & Text2. There should be no syntax errors. If you don’t need Text2 or if you need Text3, amend the routine as necessary. If you run macro TestConvertOutput, it should output the block to be deleted to the Immediate Window with any errors.
The statements in macro TestConvertOutput are those you need for macro mails. TextToBeRemoved is the value to replace “Not Internal”.