Scaling and unscaling a rectangle (not picture or OLE)

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

Is there a method or simple way of scaling up (say to 1.1) a simple rectangle
then returning it back to original size?

e.g. to animate a button where the built-in animation is not
suitable/unavailable.

If feel sure this is quite simple but am grateful for a steer.

Bob L
 
Apply an emphasis > grow shrink animation.
Set a custom zoom of 110% and press ENTER to confirm (make sure you press
enter or the default will come back)
Now double click the entry in custom animation and tick auto reverse. You
might want to trigger the animation with a click on itself.
 
John,

Unfortunately any attempt to use built-in animation effects are disabled as
all of the shapes are within groups. At this late stage I can neither afford
to ungroup them or turn them into pictures (although I would if starting from
scratch).

I tried to use Scaleheight / ScaleWidth but cannot set the unscale value
accurately enough and the shape either grows or shrinks following repeated
cycling (keypresses on the object that runs the scaling macro).

Any thoughts.
 
John,

Unfortunately any attempt to use built-in animation effects are disabled as
all of the shapes are within groups. At this late stage I can neither afford
to ungroup them or turn them into pictures (although I would if starting from
scratch).

I tried to use Scaleheight / ScaleWidth but cannot set the unscale value
accurately enough and the shape either grows or shrinks following repeated
cycling (keypresses on the object that runs the scaling macro).
Click to expand...


Here's one approach to a VBA solution (if you can use that)

Sub PumpMeUp()

With ActiveWindow.Selection.ShapeRange(1)
.Tags.Add Name:="Height", Value:=CStr(.Height)
.Tags.Add Name:="Width", Value:=CStr(.Width)
.Height = .Height * 1.1
.Width = .Width * 1.1
End With

End Sub

Sub DeflateMe()

With ActiveWindow.Selection.ShapeRange(1)
.Height = CSng(.Tags("Height"))
.Width = CSng(.Tags("Width"))
End With

End Sub

' You can use this to test it:

Sub BingePurgeMe()
Dim x As Long
With ActiveWindow.Selection.ShapeRange(1)
For x = 1 To 100
PumpMeUp
DeflateMe
Next
End With
End Sub
 
Based on Steve's code (which works in edit mode only) this would work only in
show mode (after youve used Steve's code to add the tags) and toggle between
pumped and whatever the opposite of pumped is! Give the shape an action
setting of run macro
'__ start
Sub PumpMeUpanddown(oshp As Shape)
With oshp
Select Case .Tags("height")
Case Is = CStr(.Height)
..Tags.Add Name:="Height", Value:=CStr(.Height)
..Tags.Add Name:="Width", Value:=CStr(.Width)
..Height = .Height * 1.1
..Width = .Width * 1.1
Case Is <> CStr(.Height)
..Height = CSng(.Tags("Height"))
..Width = CSng(.Tags("Width"))
End Sub
'__end
 
OOps missed a bit in the copy/paste!

Sub PumpMeUpanddown2(oshp As Shape)
With oshp
Select Case .Tags("height")
Case Is = CStr(.Height)
..Tags.Add Name:="Height", Value:=CStr(.Height)
..Tags.Add Name:="Width", Value:=CStr(.Width)
..Height = .Height * 1.1
..Width = .Width * 1.1
Case Is <> CStr(.Height)
..Height = CSng(.Tags("Height"))
..Width = CSng(.Tags("Width"))
End Select
End With
End Sub
 
John,

This worked ok and I can use it as is thanks. Always wanting a little more
I would have liked the scaling origin to be the middle of the shape but I
guess that is slightly more difficult?
 
Back
Top