Private Sub CommandButton1_Click()
    Dim oOutlookApp As Object
    Dim oItem As Object
    Dim olInsp As Object
    Dim strFname As String
    Dim wdDoc As Document
    Dim oRng As Range

        With ActiveDocument
            strFname = .SaveAs2(FileName:="C:\Users\" & Environ("Username") & "\Documents\" & _
             .SelectContentControlsByTitle("Title")(1).Range.Text & ".PDF", _
             FileFormat:=wdFormatPDF)
        End With
    
        On Error Resume Next
        'Get Outlook if it's running
        Set oOutlookApp = GetObject(, "Outlook.Application")
    
        'Outlook wasn't running, start it from code
        If Err <> 0 Then
            Set oOutlookApp = CreateObject("Outlook.Application")
        End If
        On Error GoTo 0
        'Create a new mailitem
        Set oItem = oOutlookApp.CreateItem(0)
    
        With oItem
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range
            oRng.Collapse 1
            oRng.Text = "This is the message body"
            .to = "someone@somewhere.com"
            .Subject = "This is the subject"
            .BodyFormat = 2
            .Attachments.Add strFname
            .Display
        End With
    
        'Clean up
        Set oItem = Nothing
        Set oOutlookApp = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
lbl_Exit:
        Exit Sub
End Sub