Sub FormatPara()
Dim oPara As Paragraph
Dim oRng As Range
    For Each oPara In Selection.Paragraphs
        Set oRng = oPara.Range
        oRng.End = oRng.End - 1
        If oRng.Characters(2) = "." Then
            oRng.MoveStart 2
        End If
        If InStr(1, oPara.Range.Text, ":") > 0 Then
            oRng.Collapse 1
            oRng.MoveEndUntil ":"
        End If
        TrueTitleCase oRng
    Next oPara
lbl_Exit:
    Set oPara = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

Private Sub TrueTitleCase(oRng As Range)
Dim rSel As Range
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
Dim k As Long

    Set rSel = oRng
    'count the characters in the selected string
    k = Len(rSel)
    If k < 1 Then
        'If none, then no string is selected
        'so warn the user
        MsgBox "Select the text first!", vbOKOnly, "No text selected"
        Exit Sub    'and quit the macro
    End If
    'format the selected string as title case
    vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
                      "If", "In", "Of", "On", "Or", "The", "To", "With")
    'list their replacements in a matching array
    vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
                      "if", "in", "of", "on", "or", "the", "to", "with")
    With rSel
        .Case = wdTitleWord
        'list the exceptions to look for in an array
        With .Find
            'replace items in the first list
            'with the corresponding items from the second
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Format = True
            .MatchCase = True
            For i = LBound(vFindText) To UBound(vFindText)
                .Text = vFindText(i)
                .Replacement.Text = vReplText(i)
                .Execute Replace:=wdReplaceAll
            Next i
        End With
    End With
lbl_Exit:
    Set rSel = Nothing
    Exit Sub
End Sub