VBA created shapes sometimes break ranks

[KitingJoe]

Hi,
approx. every fifth time I run the code below one shape break ranks:
Jumping a bit to the left or right or is AutoSized, so that is smaller.

What's the matter???

Thanks.
Joe

Sub Example()

Dim dblLeft As Double
Dim dblTop As Double
Dim dblLeftCurrent As Double
Dim dblWidth As Double
Dim dblHeight As Double
Dim dblA As Double

dblLeft = 60
dblTop = 200
dblLeftCurrent = dblLeft
dblWidth = 10
dblHeight = 10

For dblA = 1 To 15

ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal, dblLeftCurrent, dblTop, _
dblWidth,
dblHeight).Select
With ActiveWindow.Selection.TextRange
.Text = "X"
With .Font
.Name = "Arial"
.Size = 6
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
End With
End With
With ActiveWindow.Selection.ShapeRange
.Fill.Transparency = 0#
.Line.Weight = 0.25
.Line.Visible = msoTrue
.Line.BackColor.RGB = RGB(255, 255, 255)
.Line.Style = msoLineThinThin
.TextFrame.MarginLeft = 1
.TextFrame.MarginRight = 1
.TextFrame.MarginTop = 1
.TextFrame.MarginBottom = 1
DoEvents
With .TextFrame
.HorizontalAnchor = msoAnchorCenter
.VerticalAnchor = msoAnchorMiddle
.WordWrap = msoFalse
.AutoSize = ppAutoSizeNone
End With
End With
ActiveWindow.Selection.Unselect
dblLeftCurrent = dblLeftCurrent + dblWidth
Next
End Sub

 

[KitingJoe]

PowerPoint 2003

 

[KitingJoe]

Hi Steve,

I found exactly the same "solution" and deleted it from the example, not to
confuse anybody. Anymore I thought: "give PPT time to do the necessary
things" and inserted a DoEvents. But this makes the problem worse.

Funny enough my "configuration" now is in a mode, that no defect is annoying
me. But nothing intentional changed!?!

Hope that will last but it's a nasty thing for developers.

Ahoi, Joe