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

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