Copy Word text to a new email

  • Oct. 11, 2024

Introduction

I regularly work on larger Word documents: a statement of work for a different project, user guidelines for specific actions in PA, you name it. It happens quite often that I need to extract excerpts from the full text and send it to someone else by email. I wanted to automate this task. You might say: 'Why not doing it manually ?' Well, the code below automates the process with the click of a button (icon in the Word ribbonX) but does more than a manual copy/paste.

Instructions

I only put the cursor in the desired heading of text (paragraphs) I want to copy over. The macro does the rest:

  • select and copy the text of the selected paragraph, including the texts of all 'underlying'/depending headings or paragraphs (timesaver)
  • the Subject of an Outlook email is the title of the selected heading
  • a new email is started (saves again some clicks and time)
  • paste all selected text preserving the formatting
  • my Arabic numbered endnotes in the Word document come out as Latin numbered endnotes in Outlook, so VBA code changes this number style (if not, I need to do it manually)

VBA code

Sub Copy_Selection_To_Outlook_Email(control As IRibbonControl)


' Wim Gielis
' https://www.wimgielis.com


'''''
' VBA-code to copy paste text from Word in a new Outlook email
' 10/11/24
'''''

    Dim rng As Range
    Dim para As Paragraph
    Dim mainHeading As String
    Dim iHeadingNumber As Integer
    Dim olApp As Object
    Dim doc As Object
    Dim endnoteOptions As Object

    ' Set up the range for the paragraph where the cursor is located
    Set rng = Selection.Paragraphs(1).Range
    
    mainHeading = Trim(rng.text) ' Set the main heading as the email subject
    If Right(mainHeading, 1) = vbCr Then
        mainHeading = Left(mainHeading, Len(mainHeading) - 1)
    End If
    
    iHeadingNumber = Val(Replace(Selection.Paragraphs(1).Style, "Heading", ""))
    
    ' Expand the range to include all descendant paragraphs until the next heading
    Do
        Set para = rng.Paragraphs(rng.Paragraphs.Count).Next
        
        If para Is Nothing Then Exit Do
        
        If para.Style Like "Heading*" Then
            If Val(Replace(para.Style, "Heading", "")) <= iHeadingNumber Then Exit Do
        End If
        
        rng.End = para.Range.End
    Loop
    
    ' Copy the range text (including endnotes)
    rng.Copy
    
    ' Initialize Outlook
    On Error Resume Next
    Set olApp = GetObject(Class:="Outlook.Application")
    If olApp Is Nothing Then Set olApp = CreateObject(Class:="Outlook.Application")
    On Error GoTo 0
    
    ' Create a new mail item
    With olApp.CreateItem(0)

        .Subject = mainHeading
        .Display
        .GetInspector.WordEditor.Application.Selection.PasteAndFormat 16 '16 = wdFormatOriginalFormatting
        
        ' Access the Word editor of the active Outlook email
        Set doc = .GetInspector.WordEditor

        ' Access the endnote options in the Word editor
        On Error Resume Next
        Set endnoteOptions = doc.Endnotes
        On Error GoTo 0

        ' Check if endnotes are present
        If endnoteOptions Is Nothing Then
            MsgBox "No endnotes found in the email.", vbInformation
            Exit Sub
        End If

        ' Change the numbering format of endnotes to Arabic numerals
        endnoteOptions.NumberStyle = 0 '0 = wdNoteNumberStyleArabic

    End With


End Sub

The rest should now be easy for you. Have fun automating these otherwise tedious and boring tasks !




Homepage

Section contents

About Wim

Wim Gielis is a Business Intelligence consultant and Excel expert

Other links