power point error adding shapes

[Bennettd02]

I get the following error when trying to add a shape -

The index into the specified collection is out of bounds

My Code--

Set ppObj = New PowerPoint.Application
Set ppPres = ppObj.Presentations.Open("P:\Default\Slide Master.ppt")
'Set ppPres = ppObj.Presentations.Add
i = 1
' Setup the set of slides and populate them with data from the
' set of records.
With ppPres
    While Not rsSlide.EOF
        With .Slides.Add(rsSlide.AbsolutePosition, ppLayoutTitle)
            .Shapes(1).TextFrame.TextRange.Text = rsSlide("Title")
            i = i + 1
            While Not rsContent.EOF
                .Shapes(i).TextFrame.TextRange.Text = rsContent("Text").Value
                .Shapes(i).TextFrame.TextRange.Characters.Font.Color.RGB = RGB(255, 0, 255)
                rsContent.MoveNext
                i = i + 1
            Wend
            rsContent.MoveFirst
        End With
        rsSlide.MoveNext
    Wend

-The error appears to happen when ever i try to add a shape object of 3 or higher, would anyone one be able to point out where i am going wrong