Changing the size of a shape with VBA Code & back again

AHR239

New Member
Joined
Jun 3, 2019
Messages
2
I have the following code that will increase the size of a shape when it's clicked, and decreases it to its original size on the second click.

Sub Picture2_Click()
Dim shp As Shape
Dim big As Single, small As Single
Dim shpDouH As Double, shpDouOriH As Double
big = 2
small = 0.5
On Error Resume Next
Set shp = ActiveSheet.Shapes(Application.Caller)
With shp
shpDouH = .Height
.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
shpDouOriH = .Height

If Round(shpDouH / shpDouOriH, 2) = big Then
.ScaleHeight small, msoTrue, msoScaleFromTopLeft
.ScaleWidth small, msoTrue, msoScaleFromTopLeft
.ZOrder msoSendToBack
Else
.ScaleHeight big, msoTrue, msoScaleFromTopLeft
.ScaleWidth big, msoTrue, msoScaleFromTopLeft
.ZOrder msoBringToFront
End If
End With
End Sub

What I would like it to do is to display the shape with the top left corner positioned in cell A1 when the size is increased, and return it to its original position when the size is decreased.

Can anyone help?

Thanks in advance
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Try this:-
Code:
Option Explicit
[COLOR="Navy"]Dim[/COLOR] Mytop [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Dim[/COLOR] MyLeft [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Dim[/COLOR] Mywidth [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Dim[/COLOR] Myheight [COLOR="Navy"]As[/COLOR] Double


[COLOR="Navy"]Sub[/COLOR] Picture2_Click()
[COLOR="Navy"]With[/COLOR] ActiveSheet.Shapes(Application.Caller)
    [COLOR="Navy"]If[/COLOR] Not .Left = 0 [COLOR="Navy"]Then[/COLOR]
        Mytop = .Top
        MyLeft = .Left
        Mywidth = .Width
        Myheight = .Height
    [COLOR="Navy"]End[/COLOR] If
    
    [COLOR="Navy"]If[/COLOR] .Left = MyLeft [COLOR="Navy"]Then[/COLOR]
        .Left = 0
        .Width = Mywidth + MyLeft
        .Top = 0
        .Height = Myheight + Mytop
    [COLOR="Navy"]Else[/COLOR]
        .Left = MyLeft
        .Width = Mywidth
        .Top = Mytop
       .Height = Myheight
     [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top