Need a little help

[realitydrm]

Hello all. I need a little help. I have the following code below.

- In the sendeMail() portion of my code I would like to extract the values in a drop-down field in my word document with the title "email address". I would like the name selected to appear automatically in the email to line.
- I'm adding the Activedocument details to the subject line but would like to remove the .docx portion of the subject line. Do i need a separate outlook code to accomplish this?

Sub RunAll()
    Call Save
    
    Call sendeMail
End Sub


Sub Save()


    Dim strPath As String
    Dim strPlate As String
    Dim strName As String
    Dim strFilename As String
    Dim oCC As ContentControl
     
    strPath = "C:\Users\******x\Desktop\Test 4"
    CreateFolders strPath
    
    On Error GoTo err_Handler
    Set oCC = ActiveDocument.SelectContentControlsByTitle("License Plate Number").Item(1)
    If oCC.ShowingPlaceholderText Then
        MsgBox "Complete the License plate number!"
        oCC.Range.Select
        GoTo lbl_Exit
    Else
        strPlate = oCC.Range.Text
    End If
     
    Set oCC = ActiveDocument.SelectContentControlsByTitle("Customer Name").Item(1)
    If oCC.ShowingPlaceholderText Then
        MsgBox "Complete the Customer Name!"
        oCC.Range.Select
        GoTo lbl_Exit
    Else
        strName = oCC.Range.Text
    End If
     
    strFilename = strPlate & "__" & strName & ".docx"
    ActiveDocument.SaveAs2 FileName:=strPath & strFilename, FileFormat:=12
lbl_Exit:
    Set oCC = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub




Private Sub CreateFolders(strPath As String)
    
    Dim oFSO As Object
    Dim lngPathSep As Long
    Dim lngPS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lngPathSep = InStr(3, strPath, "\")
    If lngPathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
        If lngPathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lngPathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
            oFSO.CreateFolder Left(strPath, lngPathSep)
        End If
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
    Exit Sub
End Sub


Private Sub sendeMail()
Dim olkApp As Object
Dim strSubject As String
Dim strTo As String
Dim strBody As String
Dim strAtt As String


    strSubject = "VR*** Request:   " + ActiveDocument + "    CUSTOMER IS xx xx xx"
    strBody = ""
    strTo = ""
    If ActiveDocument.FullName = "" Then
        MsgBox "activedocument not saved, exiting"
        Exit Sub
    Else
        If ActiveDocument.Saved = False Then
            If MsgBox("Activedocument NOT saved, Proceed?", vbYesNo, "Error") <> vbYes Then Exit Sub
        End If
    End If
    strAtt = ActiveDocument.FullName
    
    Set olkApp = CreateObject("outlook.application")
    With olkApp.createitem(0)
        .To = strTo
        .Subject = strSubject
        .body = strBody
        .attachments.Add strAtt
        '.send
        .Display
    End With
    Set olkApp = Nothing
End Sub