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

[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