How about something like this? When you click on your picture, its size increases 50% (or some other chosen number). And when you again click on your picture, it returns to its original size. If so, insert the following code in the sheet module for the sheet containing the picture (right-click the sheet tab, and select 'View Code')...
Now, assign 'Picture_Click' as the macro for your picture (right-click the picture, select 'Assign Macro', and select 'Picture_Click'). If you have more than one picture that you'd like to re-size, assign each picture with the macro 'Picture_Click'. If you have many pictures, you can use the following macro that needs to be place in a regular module to assign 'Picture_Click' to all pictures on your worksheet...Code:Option Explicit Private Sub Picture_Click() Static Dict As Dictionary Static MyPics() As Variant Static Cnt As Long Static c As Long Dim Shp As Shape Cnt = Cnt + 1 If Cnt = 1 Then Set Dict = CreateObject("Scripting.Dictionary") End If Set Shp = Me.Shapes(Application.Caller) If Not Dict.Exists(Shp.Name) Then c = c + 1 Dict.Add Shp.Name, c ReDim Preserve MyPics(1 To 2, 1 To c) MyPics(1, c) = Shp.Name MyPics(2, c) = True End If If MyPics(2, Dict.Item(Shp.Name)) = True Then MyPics(2, Dict.Item(Shp.Name)) = False Shp.ScaleHeight 1.5, msoTrue 'increase height by 50% Shp.ScaleWidth 1.5, msoTrue 'increase width by 50% Else MyPics(2, Dict.Item(Shp.Name)) = True Shp.ScaleHeight 1, msoTrue 'scale to original height Shp.ScaleWidth 1, msoTrue 'scale to original width End If End Sub
Lastly, in case you or some user saves the workbook when your picture or pictures are at an increased size, the following will ensure that they're re-sized to their original sizes when the workbook is opened...Code:Sub AssignMacro() Dim Shp As Shape For Each Shp In Sheet1.Shapes 'change the sheet name accordingly If Shp.Type = 13 Then 'picture Shp.OnAction = "Sheet1.Picture_Click" End If Next Shp End Sub
In a regular module:
In the code module for 'ThisWorkbook' (double-click the icon for 'ThisWorkbook' in the Project Explorer window)...Code:Sub ResetToOriginalSize() Dim Shp As Shape For Each Shp In Sheet1.Shapes If Shp.Type = 13 Then 'picture Shp.ScaleHeight 1, msoTrue 'scale to original height Shp.ScaleWidth 1, msoTrue 'scale to original width End If Next Shp End Sub
Code:Private Sub Workbook_Open() Call ResetToOriginalSize End Sub