General code for photos

[mmn1000]

Hello
I use the following code to enlarge photos in Excel

Sub all_Click()

 Dim H  As Long

 Dim w  As Long

 Dim Shp  As Shape

 For Each Shp In ActiveSheet.Shapes

     If Shp.Type = 13 Then

        Shp.Width = Shp.TopLeftCell.Width * 3

        Shp.Height = Shp.TopLeftCell.Height * 3

     End If

 Next Shp

 With ActiveSheet.Shapes(Application.Caller).OLEFormat.Object

        .Width = .TopLeftCell.Width * 6

        .Height = .TopLeftCell.Height * 11

        .ShapeRange.ZOrder msoBringToFront

 End With

End Sub

Good for a few right-click photos and select Assign Macro

Now I want to use this code for a lot of shared photos
By clicking on each photo, I can enlarge it
If I want to use the right click method, it's time consuming and tedious
How can I make this code public for all photos to zoom in on them?
Or the new photo that I add to the file will automatically follow this code
I hope I get what I want

 

[mmn1000]

Pic222.xlsm

Microsoft Excel Workbook

onedrive.live.com

Pic222.xlsm

Microsoft Excel Workbook

1drv.ms

 

[Fluff]

Ok, thanks for that.
The problem is the pictures on the last row have the same names as the pictures on the first row. You will need to rename them so that all pictures have a unique name.

 

[mmn1000]

Professor
Can you for the following code
Like the code above
Created a public code
Because each is used in separate sheets

Sub Resize_Picture()

Dim Shp As Shape
    Dim big As Single, small As Single
    Dim shpDouH As Double, shpDouOriH As Double
    big = 5
    small = 1
    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

And

Sub all_Click()
fd = fd Xor True
Dim H As Long
 Dim w As Long
With ActiveSheet.Shapes(Application.Caller).OLEFormat.Object
    If fd Then
        .Width = .TopLeftCell.Width * 3
        .Height = .TopLeftCell.Height * 3
    Else
        .Width = .TopLeftCell.Width * 6
        .Height = .TopLeftCell.Height * 11
    End If
   .ShapeRange.ZOrder msoBringToFront
End With
End Sub

Thank you for bothering me

 

[mmn1000]

Ok, thanks for that.
The problem is the pictures on the last row have the same names as the pictures on the first row. You will need to rename them so that all pictures have a unique name.

I guess I wanted to make sure

 

[Fluff]

You can just change the name of the macro in he code from post#4 like

       Sub mmn()
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
If Shp.Type = 13 Then Shp.OnAction = "Resize_Picture"
Next Shp
End Sub