Create Rectangle-Shape with positioning

Hi Everybody
I'm looking for a solution for the following Problem:
I have documents with different kinds of rectangles and text. What I want to do is to get the position and the size of each of these rectangles and create a new Rectangle with exact the same position and size but with other line properties and then delete the first rectangle.
What I have is:

Sub typ()
Dim shp As Shape
Dim shpneu As Shape
Dim pos As String
Dim styp As Byte
Dim sel As ShapeRange
Dim hoch As Double, breit As Double, posh As Double, posl As Double
For Each shp In ActivePage.Shapes
If shp.Type = 3 Then
hoch = shp.SizeHeight
breit = shp.SizeWidth
posh = shp.PositionX
posl = shp.PositionY
Set shp = ActiveLayer.CreateRectangle(posl, posh, (posl + breit), (posh + hoch))
shp.Outline.SetProperties 0.003
End If
Next shp
End Sub

This creates a new Rectangle with the right size but the Position is different and I don't understand why?
Anybody out there who has an Idea??
Greetings
Werner

If you are deleting the origional, why not just set it's outline?

Sub typ()
Dim shp As Shape
For Each shp In ActivePage.Shapes
   If shp.Type = 1 Then shp.Outline.SetProperties 0.003
Next shp
End Sub

(Btw rectangle is type 1)

Alternitivly you could try this:

Sub typ()
    Dim shp As Shape
    Dim shpneu As Shape
    Dim DblL, DblR, DblT, DblB As Double
    For Each shp In ActivePage.Shapes
        If shp.Type = cdrRectangleShape Then
            DblT = shp.TopY
            DblB = shp.BottomY
            DblR = shp.RightX
            DblL = shp.LeftX
            Set shpneu = ActiveLayer.CreateRectangle(DblL, DblT, DblR, DblB)
            shpneu.Outline.SetProperties 0.003
            shp.Delete
        End If
    Next shp
End Sub

Hi Everybody
no need anymore to think about. I got it.

Sub typ()
Dim shp As Shape
Dim gr As ShapeRange
Dim shpneu As Shape
Dim pos As String
Dim styp As Byte
Dim sel As ShapeRange
Dim hoch As Double, breit As Double, posh As Double, posl As Double
Dim OrigSelection As ShapeRange
ActiveLayer.Paste
    Set OrigSelection = ActiveSelectionRange
    Dim grp1 As ShapeRange
    ActiveSelection.Ungroup
For Each shp In ActivePage.Shapes
If shp.Type = 3 Then
hoch = shp.SizeHeight
breit = shp.SizeWidth
posh = shp.PositionX
posl = shp.PositionY
Set shpneu = ActiveLayer.CreateRectangle(posl, posh, (posl + breit - 0.006), (posh + hoch - 0.006))
shpneu.PositionX = posh
shpneu.PositionY = posl
With shpneu.Outline
        .Type = cdrOutline
        .Width = 0.003
        .Color.CMYKAssign 0, 100, 100, 0
        .NibStretch = 100
        .NibAngle = 0#
        .BehindFill = False
        .ScaleWithShape = False
        .LineCaps = 0
        .LineJoin = 0
    End With
shp.Delete
End If
Next shp
End Sub

Thank you all for reading the thread.
Greetings
Werner