Consulting

Results 1 to 5 of 5

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

  1. #1
    VBAX Regular
    Joined
    Oct 2014
    Posts
    95
    Location

    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

    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

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Regular
    Joined
    Oct 2014
    Posts
    95
    Location
    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.

  4. #4
    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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    VBAX Regular
    Joined
    Oct 2014
    Posts
    95
    Location
    Many thanks for this adjustment. I'm sorry for the delay in replying - I was unwell.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •