Sub Send_Selected_Page_As_Mail_Attachment()
'Graham Mayor - https://www.gmayor.com - Last updated - 01 May 2020
'Send the current page of the document as an attachment _
  in an Outlook Email message
'Requires the code from - http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to either retrieve an open instance of Outlook or open Outlook if it is closed.
Dim bStarted As Boolean
Dim olApp As Object
Dim oItem As Object
Dim oDoc As Document
Dim olInsp As Object
Dim wdDoc As Document
Dim oRng As Range
Dim oTempDoc As Document
Dim strName As String
Dim strPath As String
Dim oHeader As HeaderFooter, oFooter As HeaderFooter

    Set oDoc = ActiveDocument
    'Save the document
    oDoc.Save
    If Len(oDoc.Path) = 0 Then
        MsgBox "Document must first be saved"
        GoTo lbl_Exit
    End If

    'Copy the selected page
    oDoc.Bookmarks("\page").Range.Copy

    'Prompt the user to save the document
    strPath = Environ("TEMP") & "\PageCopy.docx"

    On Error GoTo err_Handler:
    WordBasic.DisableAutoMacros 1
    Set oTempDoc = Documents.Add(Template:=oDoc.FullName)
    For Each oHeader In oTempDoc.Sections(1).Headers
        oHeader.Range.Text = ""
    Next
    For Each oFooter In oTempDoc.Sections(1).Footers
        oFooter.Range.Text = ""
    Next
    oTempDoc.Range.Text = ""
    oTempDoc.Range.Paste
    oTempDoc.SaveAs2 FileName:=strPath, AddToRecentFiles:=False
    oTempDoc.Close
    WordBasic.DisableAutoMacros 0

    'Get Outlook if it's running
    Set olApp = OutlookApp()
    On Error GoTo 0
    'Create a new mailitem

    Set oItem = olApp.CreateItem(0)

    With oItem
        .Subject = "This is the subject"
        .Attachments.Add strPath
        .BodyFormat = 2
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        oRng.Collapse 1
        oRng.Text = "This is the coveriung message text" _
                    & vbCr & vbCr & "Another line of message text! ... etc"
        .Display
    End With
    'delete the temporary file
    Kill strPath
lbl_Exit:
    Set oItem = Nothing
    Set olApp = Nothing
    Set oTempDoc = Nothing
    Set oDoc = Nothing
    Set olInsp = Nothing
    Set oRng = Nothing
    Set wdDoc = Nothing
    Exit Sub
err_Handler:
    Err.Clear
    GoTo lbl_Exit
End Sub