Dim str1 As String, str2 As String

With ActiveDocument
    .Select
    With Selection
        .Find.ClearFormatting
        .Find.Execute FindText:="The Principal", MatchWholeWord:=True
        .HomeKey
        .MoveDown
        .EndKey Unit:=wdLine
        .MoveLeft Unit:=wdCharacter, Count:=1
        .HomeKey Unit:=wdLine, Extend:=wdExtend
        str1 = Trim(Selection.Range.Text)
    End With
    .Select
    With Selection
        .Find.Execute FindText:="RE: ", MatchWholeWord:=True
        .MoveRight Unit:=wdCharacter, Count:=1
        .EndKey Unit:=wdLine, Extend:=wdExtend
        str2 = Trim(Selection.Range.Text)
    End With
    .SaveAs2 FileName:=ThisDocument.Path & "\" & str1 & " " & str2, FileFormat:=wdFormatDocumentDefault
End With