Delete text in incoming email

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 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 &amp; 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›&copy; 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 &ndash; the UK&rsquo;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 &amp; 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 &ndash; the UK&rsquo;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”.

Answer 3

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.