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

[1819]

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

[gmayor]

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.


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

[1819]

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.

[gmayor]

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

oTarget.Paste
and adding the line

oTarget.Font.Bold = True
immediately after it.

[1819]

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