Sub Apply_True_Title_Case_by_Style()
Dim oRng As Range
Dim oPara As Paragraph
Dim StyleName As String
Dim vFindText As Variant
Dim vReplText As Variant
Dim wrd As Integer

    StyleName = "Heading 1"
    vFindText = Array("A", "An", "And", "As", "At", "But", "By", "For", _
                      "If", "In", "Of", "On", "Or", "The", "To", "With")
    vReplText = Array("a", "an", "and", "as", "at", "but", "by", "for", _
                      "if", "in", "of", "on", "or", "the", "to", "with")

    For Each oPara In ActiveDocument.Paragraphs
        If oPara.Style = StyleName Then
            Set oRng = oPara.Range
            oRng.Case = wdTitleWord
            With oRng.Find
                For wrd = LBound(vFindText) To UBound(vFindText)
                    .Text = vFindText(wrd)
                    .Replacement.Text = vReplText(wrd)
                    .Execute MatchCase:=True, Replace:=wdReplaceAll
                Next wrd
            End With
        End If
    Next oPara
End Sub