Centering a Shape over a given cell when resizing

[Linking to specific cells in pivot table]

Hi,

I have a macro set up to re-size a Shape (or Autoshape -- it's a trapezoid)
based on values input into a cell on the spreadsheet. The problem is that it
looks like the macro is simply extending one side of the Shape rather than
all sides of the shape equally, resulting in the object no longer being
centered over the same point in the spreadsheet it was originally centered
over. I need to find a way to have the Shape remain centered over the same
point in the spreadsheet after being re-sized.

Below is the code I have for the re-sizing -- any help is greatly appreciated!

ActiveSheet.Shapes("AutoShape 18").Select

sourcevar = Range("C9").Value - 0.167 + 1

If sourcevar < 1.5 Then
Selection.ShapeRange.Height = 83.57763975 * sourcevar
Selection.ShapeRange.Width = 99.1875 * sourcevar
Else

Selection.ShapeRange.Height = 83.57763975 * 1.5
Selection.ShapeRange.Width = 99.1875 * 1.5
End If

 

[Tom Ogilvy]

the shape has
Top
Left
Height
Width

properties. You will have to calculate the adjustments you need to Top and
Left based on the changes you made to Height and Width

 

[Linking to specific cells in pivot table]

Hi Tom,

Thanks for your reply. I'm now trying to capture the original top and left
values through variables and then using these values to help calculate the
new top and left values I would like after the resizing. The problem is that
I can't get the code right to capture the original top and left values -- I
get the "Run-time error 438 -- Object doesn't support this property or method
" error when I execute the following code --any help is appreciated!

Sub resizing()

Dim sourcevar
Dim currenttop
Dim currentleft

Sheets("1st Level Graph").Select

'Sources and Conveyer
ActiveSheet.Shapes("AutoShape 18").Select

'Below is where I am getting the error
currenttop = ActiveSheet.Selection.ShapeRange.Top.Value
currentleft = ActiveSheet.Selection.ShapeRange.Left.Value


sourcevar = Range("C9").Value - 0.167 + 1

If sourcevar < 1.5 Then
Selection.ShapeRange.Height = 83.57763975 * sourcevar
Selection.ShapeRange.Width = 99.1875 * sourcevar
Selection.ShapeRange.Top = currenttop + ((83.57763975 * sourcevar) -
83.57763975)
Selection.ShapeRange.Left = currentleft + ((99.1875 * sourcevar) -
99.1875)
Else

Selection.ShapeRange.Height = 83.57763975 * 1.5
Selection.ShapeRange.Width = 99.1875 * 1.5
Selection.ShapeRange.Top = currenttop + ((83.57763975 * 1.5) -
83.57763975)
Selection.ShapeRange.Left = currentleft + ((99.1875 * 1.5) - 99.1875)

End If

 

[Tom Ogilvy]

currenttop = ActiveSheet.Selection.ShapeRange.Top
currentleft = ActiveSheet.Selection.ShapeRange.Left

No value on the end.

Demo from the immediate window:
the selection was a trapezoid from the Autoshapes:

? typename(selection)
Rectangle
? selection.Name
AutoShape 1
? selection.ShapeRange.top
189.75
? selection.ShapeRange.Left
362.25
? selection.top
189.75
? selection.Left
362.25



--
Regards,
Tom Ogilvy


"Linking to specific cells in pivot table"

 

[jjk]

Is this what you want??

ActiveSheet.Shapes("AutoShape 18").Select

sourceVar = Range("A1").Value - 0.167 + 1

prevCenterH = Selection.ShapeRange.Left +
(Selection.ShapeRange.Width / 2)
prevCenterV = Selection.ShapeRange.Top +
(Selection.ShapeRange.Height / 2)

If sourceVar < 1.5 Then
Selection.ShapeRange.Height = 83.57763975 * sourceVar
Selection.ShapeRange.Width = 99.1875 * sourceVar
Else
Selection.ShapeRange.Height = 83.57763975 * 1.5
Selection.ShapeRange.Width = 99.1875 * 1.5
End If

Selection.ShapeRange.Left = prevCenterH -
(Selection.ShapeRange.Width / 2)
Selection.ShapeRange.Top = prevCenterV -
(Selection.ShapeRange.Height / 2)


Regards,
Jayant

 

[Linking to specific cells in pivot table]

Thanks Tom!

currenttop = ActiveSheet.Selection.ShapeRange.Top
currentleft = ActiveSheet.Selection.ShapeRange.Left

No value on the end.

Demo from the immediate window:
the selection was a trapezoid from the Autoshapes:

? typename(selection)
Rectangle
? selection.Name
AutoShape 1
? selection.ShapeRange.top
189.75
? selection.ShapeRange.Left
362.25
? selection.top
189.75
? selection.Left
362.25



--
Regards,
Tom Ogilvy


"Linking to specific cells in pivot table"

 

[Linking to specific cells in pivot table]

This is great! Thanks!