The following macro will copy the selected page of the document to a new temporary document and attach that new document to an e-mail message. The temporary document is then deleted. Note the comment at the start of the macro about additional code required!
Code:
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