Outlook VBA to extract certain formats of text from emails in folder to Word document

Hi

The following code works in Word to extract all highlighted text to a new Word document.

I need code to work on Outlook emails but in a slightly different way.

I would like the code to:

1) read all emails in a particular subfolder of my Inbox (let's call the folder Test)
2) in each email, copy any hyperlinks, bold text and highlighted text to a single Word file (let's call it C:\TestFile.docx)
3) the formatting of the hyperlink and the bold text need to be preserved
4) the highlighting needs to be switched off so the text is black/ automatic
5) the results of each email need to be added to the bottom of the Word file, in the order they were found in the Outlook folder.

Many thanks

Code:

---

Sub Highlights()
'
' Highlights Macro

Dim oHighlights() As String
Dim Hl As Integer 'highlighted range counter
Dim i As Integer ' loop counter
Dim j As Integer ' loop counter
Dim aRange As Range
Dim oWord As Object


'Application.ScreenUpdating = False
On Error GoTo errorHandler

i = 0 ' cumulative word counter
j = 0 ' inner loop counter used in testing
      'whether a word adjacent to a highlighted word
      'is itself highlighted

For Each oWord In ActiveDocument.Words
    i = i + 1
    j = 0
    If i >= ActiveDocument.Words.Count Then
        If LBound(oHighlights) < UBound(oHighlights) Then ' trigger error 9 if array empty
            Documents.Add
            For Hl = LBound(oHighlights) To UBound(oHighlights)
                Selection.TypeText oHighlights(Hl) & Chr(13)
            Next Hl
            MsgBox ("All done")
            Exit Sub
        End If
    End If
   
    ActiveDocument.Words(i).Select
    If Selection.Range.HighlightColorIndex <> wdAuto Then
        'Loop to test adjacent words for highlighting
        Do Until ActiveDocument.Words(i + 1).HighlightColorIndex = wdAuto
            If ActiveDocument.Words(i + 1).HighlightColorIndex <> wdAuto Then
                i = i + 1 'increment the word count
                ActiveDocument.Words(i).Select
                j = j + 1 'inner loop counter
            End If
        Loop
                'create a range and
                'redefine the range
                Set aRange = ActiveDocument.Words(i - j)
                aRange.SetRange Start:=aRange.Start, End:=ActiveDocument.Words(i).End
                'Do some text formatting
                With aRange
                    .Font.Bold = False
                    .Font.Size = 12
                'copy to an array
                    Hl = Hl + 1
                    ReDim Preserve oHighlights(Hl)
                    oHighlights(Hl) = aRange.Text
                End With
    End If
   
Next
errorHandler:
Select Case Err.Number
Case 9
MsgBox ("Error numbered " & Err.Number & " occurred." & Chr(13) & "Did you highlight any text? " & Chr(13) & Err.Description _
& Chr(13) & "Exiting macro now")
Case Else
MsgBox ("Error numbered " & Err.Number & " occurred. " & Chr(13) & Err.Description)
End Select
Exit Sub

End Sub

---

Unless the messages are similar in format, the resulting document will be an incomprehensible mess, and if they are similar in format you may be better with http://www.gmayor.com/extract_email_data_addin.htm. However, the following is about as close as you can readily get to what you asked. You can modify it as required.

Code:

---

Option Explicit

Sub ExtractStuff()
'Graham Mayor - http://www.gmayor.com - Last updated - 19/11/2016
Dim olFolder As Folder
Dim olItem As Object
Dim olInsp As Inspector
Dim wdApp As Object
Dim oDoc As Object
Dim wdDoc As Object
Dim oRng As Object
Dim oTarget As Object
Dim hLink As Object
Dim olink As Object

    Set olFolder = Session.GetDefaultFolder(olFolderInbox).folders("Test")
    'Set olFolder = Session.PickFolder
    If olFolder.Items.Count = 0 Then
        MsgBox "No messages in the folder"
        GoTo lbl_Exit
    End If

    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    Set oDoc = wdApp.Documents.Add
    wdApp.Visible = True

    For Each olItem In olFolder.Items
        If TypeName(olItem) = "MailItem" Then
            Set oTarget = oDoc.Range
            oTarget.collapse 0
            With olItem
                Set olInsp = .GetInspector
                Set wdDoc = olInsp.WordEditor
                Set oRng = wdDoc.Range
                For Each hLink In oRng.Hyperlinks
                    Set olink = hLink.Range
                    Set oTarget = oDoc.Range
                    oTarget.collapse 0
                    olink.Copy
                    oTarget.Paste
                    oTarget.InsertParagraphAfter
                Next hLink
                With oRng.Find
                    .Highlight = True
                    Do While .Execute(Forward:=True)
                        If InStr(1, LCase(oRng.Style.NameLocal), "hyperlink") = 0 Then
                            oTarget.Text = oRng.Text
                            oTarget.InsertParagraphAfter
                            Set oTarget = oDoc.Range
                            oTarget.collapse 0
                            oRng.collapse 0
                        End If
                    Loop
                End With
                With oRng.Find
                    .Font.Bold = True
                    .Highlight = False
                    Do While .Execute(Forward:=True)
                        If InStr(1, LCase(oRng.Style.NameLocal), "hyperlink") = 0 Then
                            oRng.Copy
                            oTarget.Paste
                            oTarget.InsertParagraphAfter
                            Set oTarget = oDoc.Range
                            oTarget.collapse 0
                            oRng.collapse 0
                        End If
                    Loop
                End With
            End With
        End If
    Next olItem
lbl_Exit:
    Exit Sub
End Sub

---

Many thanks Graham. That does exactly what I need. The bold text comes across into the Word document as normal font, which I can handle, but if there's an easy fix for that in the code, it would be even better. Thanks again.

You can force the bold font on the segment of code that isn't working by locating

Code:

---

oTarget.Paste

---

and adding the line

Code:

---

oTarget.Font.Bold = True

---

immediately after it.

Many thanks for this adjustment. I'm sorry for the delay in replying - I was unwell.