VBA: Move and Size Pics

[NeoSez]

Hello. I am trying resize all the photos in all the sheets to be 3 inches in width only, but maintain aspect ratio. I do not want the photos to move and size with cells. Photos should move with the cells but don't size with cells. It should always maintain the exact width of 3 inches.

Here is what I have so far and it's not working. Please help tweak. Thank you.

Sub MoveButDontSizeWithCells()
    Dim xPic As Picture
    On Error Resume Next
    Application.ScreenUpdating = False
    For Each xPic In ActiveSheet.Pictures
        xPic.Placement = xlMoveButDontSize
        .ShapeRange.LockAspectRatio =msoTrue
        .Width = 300
    Next
    Application.ScreenUpdating = True
End Sub

 

[Domenic]

When I commented out On Error Resume Next, I got the following error...

Compile error:

Invalid or unqualified reference

...and it highlited this lines...

.ShapeRange.LockAspectRatio =msoTrue

So you can easily see that ShapeRange needs to be qualified with a reference to the Picture object...

xPic.ShapeRange.LockAspectRatio =msoTrue

And, the same thing happened with .Width. Also, the Placement property should be assigned xlMove. So you macro should be amended as follows...

Sub MoveButDontSizeWithCells()
    Dim xPic As Picture
    'On Error Resume Next
    Application.ScreenUpdating = False
    For Each xPic In ActiveSheet.Pictures
        With xPic
            .Placement = xlMove
            .ShapeRange.LockAspectRatio = msoTrue
            .Width = 300
        End With
    Next
    Application.ScreenUpdating = True
End Sub

However, I would suggest looping through the Shapes collection instead of Pictures, and then test whether the shape is in fact a picture. Otherwise you'll get an error if your worksheet contains other objects, such as an ActiveX commandbutton.

Sub MoveButDontSizeWithCells()
    Dim shp As Shape
    Application.ScreenUpdating = False
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoPicture Then
            With shp
                .Placement = xlMove
                .LockAspectRatio = msoTrue
                .Width = 300
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Hope this helps!

 

[NeoSez]

When I commented out On Error Resume Next, I got the following error...

Compile error:

Invalid or unqualified reference

...and it highlited this lines...

.ShapeRange.LockAspectRatio =msoTrue

So you can easily see that ShapeRange needs to be qualified with a reference to the Picture object...

xPic.ShapeRange.LockAspectRatio =msoTrue

And, the same thing happened with .Width. Also, the Placement property should be assigned xlMove. So you macro should be amended as follows...

Sub MoveButDontSizeWithCells()
    Dim xPic As Picture
    'On Error Resume Next
    Application.ScreenUpdating = False
    For Each xPic In ActiveSheet.Pictures
        With xPic
            .Placement = xlMove
            .ShapeRange.LockAspectRatio = msoTrue
            .Width = 300
        End With
    Next
    Application.ScreenUpdating = True
End Sub

However, I would suggest looping through the Shapes collection instead of Pictures, and then test whether the shape is in fact a picture. Otherwise you'll get an error if your worksheet contains other objects, such as an ActiveX commandbutton.

Sub MoveButDontSizeWithCells()
    Dim shp As Shape
    Application.ScreenUpdating = False
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoPicture Then
            With shp
                .Placement = xlMove
                .LockAspectRatio = msoTrue
                .Width = 300
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Hope this helps!

Domenic​

Thank you so much for the explanations. As a noob, it really helps me learn.
Just tried your script and it works really well. However, I have a couple of questions.

1. How do I get it to run for all the sheets in the Workbook?
2. How to get the resized photos to stay inside the cell?

 

[Domenic]

To run the macro for all worksheets within the active workbook, try...

Sub MoveButDontSizeWithCells()
    Dim ws As Worksheet
    Dim shp As Shape
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        For Each shp In ws.Shapes
            If shp.Type = msoPicture Then
                With shp
                    .Placement = xlMove
                    .LockAspectRatio = msoTrue
                    .Width = 300
                End With
            End If
        Next shp
    Next ws
    Application.ScreenUpdating = True
End Sub

For your second question, I'm unclear. Can you please elaborate?

 

[NeoSez]

To run the macro for all worksheets within the active workbook, try...

Sub MoveButDontSizeWithCells()
    Dim ws As Worksheet
    Dim shp As Shape
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        For Each shp In ws.Shapes
            If shp.Type = msoPicture Then
                With shp
                    .Placement = xlMove
                    .LockAspectRatio = msoTrue
                    .Width = 300
                End With
            End If
        Next shp
    Next ws
    Application.ScreenUpdating = True
End Sub

For your second question, I'm unclear. Can you please elaborate?

For your second question, I'm unclear. Can you please elaborate?

Thank you for the quick response.
The second part, there are some pics that are long and it extends into the cells below. How to make it fit into the cell without extending into surrounding cells.