Centering all Images to cells in Column "A"

[frisbeenut]

I have a spreadsheet with many images inserted in Column "A" of sheet "Inventory & Sales". I am hopeful someone here can provide a VBA macro that will scroll through all cells in column "A" and if the cell contains an image, then center the image to the cell, and if there is no image, then skip that cell and process until the last image in the last row that contains data. It is assumed there is only one image per cell.

Thanks in advance.

 

[jolivanes]

Try this on a copy of your workbook.

Sub Maybe()
Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Column = 1 Then
            With shp
                .Top = Range(shp.TopLeftCell.Address).Top + ((Range(shp.TopLeftCell.Address).Height - shp.Height) / 2)
                .Left = Range(shp.TopLeftCell.Address).Left + ((Range(shp.TopLeftCell.Address).Width - shp.Width) / 2)
            End With
        End If
    Next shp
End Sub

 

[frisbeenut]

Thanks and it worked great.

 

[jolivanes]

This

.Left = Range(shp.TopLeftCell.Address).Left + ((Range(shp.TopLeftCell.Address).Width - shp.Width) / 2)

should be replaced by

.Left = (Range(shp.TopLeftCell.Address).Width - shp.Width) / 2

because it will always be for Column A
Good Luck and stay safe

 

[frisbeenut]

I know this is a little bit of a topic change, but since we are working with every image in column "A", I would like to lock the aspect ratio and then resize the image to 95% fit the cell and maintain the original aspect ratio. The image can be either landscape or portrait, so the image height needs to be equal to or less than 95% of the cell height and at the same time the image width needs to be less than or equal to 95% of the cell width.

One last wish item would be to have a variant of this macro that prompts the user to select and insert an image from file using the FileDialog function. I know this variant will only insert into column "A" of the current row and it will not need to process every cell in column "A".

Thanks so much, any and all help is greatly appreciated.

 

[p45cal]

jolivanes, you surprise me with:

.Top = Range(shp.TopLeftCell.Address).Top + ((Range(shp.TopLeftCell.Address).Height - shp.Height) / 2)

perhaps:

.Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2

?

 

[frisbeenut]

One potential problem sizing images to fit cell sizes is dealing with images that are rotated 90 or 270. Note: my images are only rotated orthographically 0, 90, 180, & 270.

 

[jolivanes]

I did not think that I could surprise you anymore P45cal!!!!
Going too fast has it's drawbacks I guess. Should check a little closer before answering.
Thank you P45cal and stay safe. We need you to continue with the good work you do.

 

[jolivanes]

re-visited and re-done.
I prefer multiplying over dividing also.
My apologies.

Sub Maybe()
Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Column = 1 Then
            With shp
                .Left = 0.5 * (.TopLeftCell.Width - .Width)
                .Top = .TopLeftCell.Top + 0.5 * (.TopLeftCell.Height - .Height)
            End With
        End If
    Next shp
End Sub

 

[p45cal]

One potential problem sizing images to fit cell sizes is dealing with images that are rotated 90 or 270. Note: my images are only rotated orthographically 0, 90, 180, & 270.

I'm struggling with this at the moment, I can't find a way of 'resetting' the picture so that its height is its height and its width, width after rotation. I was able to do it with cut and paste-special back, but it degraded the quality of the picture a lot. Yes, I could just do some calculations using transposed height and width but first I'll experiment with temporary grouping of the picture and, say, a dot overlaid on it, to see if that will let me do it and I'll have a muse about doing some trigonometry and working out where the picture should be (but it will be confined to rectangular pictures) although this last should allow for any degree of rotation, not just orthogonal rotations.

 

[frisbeenut]

Probably not very efficient coding, but this code seems to work. However, it crashed due to a divide by zero error when it tried to process a line shape.

'Works with images that are rotated 0, 90, 180, and 270 degrees only!
Sub Resize_and_Center_Images()
Dim shp As Shape
Dim iw As Integer
Dim ih As Integer
Dim ir As Integer
Dim cw As Integer
Dim ch As Integer
Dim nw As Integer
Dim nh As Integer
Dim ratio As Single
Dim padding As Integer
   ratio = 1 'used if image size is to be a percentage of cell size
   padding = 5 'used for uniform margin for cell if desired
    For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Column = 1 Then
            iw = shp.Width
            ih = shp.Height
            ir = shp.Rotation
            If ir = 180 Then ir = 0
            If ir = 270 Then ir = 90
            cw = shp.TopLeftCell.Width
            ch = shp.TopLeftCell.Height
            nw = (cw * ratio) - padding
            nh = (ch * ratio) - padding
            With shp
              .LockAspectRatio = msoTrue
              If cw / iw <= ch / ih And ir = 0 Then 'cell width controls image width
                     .Width = nw
                ElseIf cw / iw > ch / ih And ir = 0 Then 'cell height controls image height
                     .Height = nh
                ElseIf cw / ih <= ch / iw And ir = 90 Then 'cell width controls image height
                     .Height = nw
                ElseIf cw / ih > ch / iw And ir = 90 Then 'cell height controls image width
                     .Width = nh
              End If
                .Top = Range(shp.TopLeftCell.Address).Top + ((Range(shp.TopLeftCell.Address).Height - shp.Height) / 2)
                .Left = Range(shp.TopLeftCell.Address).Left + ((Range(shp.TopLeftCell.Address).Width - shp.Width) / 2)
            End With
        End If
    Next shp
End Sub

 

[p45cal]

The attached has a macro blah that takes 3 arguments: the picture, its destination range (cell) and a value to handle the 95% you mentioned in msg#5.
The button calls the macro Maybe3. This macro is a bit rough since it looks at all shapes on the sheet and things such as dropdown arrows for an autofilter are shapes too, so it may balk if it encounters anything like that.
It handles any rotation.
The blah code:

Sub blah(Pic, Destn, pcnt)
With Pic
  DL = (.Height ^ 2 + .Width ^ 2) ^ 0.5 'Pythagoras
  Angle = Atn(.Height / .Width) 'trig.
  NA1 = Angle - Application.Radians(.Rotation) 'more trig.
  NA2 = Angle + Application.Radians(.Rotation) 'and more.
 
  myNW = Application.Max(Abs(DL * Cos(NA1)), Abs(DL * Cos(NA2))) 'even more trig.
  myNH = Application.Max(Abs(DL * Sin(NA1)), Abs(DL * Sin(NA2)))
  'scale to fill cell:
  CW = Destn.Width
  CH = Destn.Height
 
  .LockAspectRatio = msoTrue
  .ScaleHeight Application.Min(CW * pcnt / myNW, CH * pcnt / myNH), msoFalse, msoScaleFromTopLeft 'scale
  .IncrementLeft (Destn.Left + CW / 2) - (.Left + .Width / 2) 'move
  .IncrementTop (Destn.Top + CH / 2) - (.Top + .Height / 2) 'move
End With    'Pic
End Sub

It's a bit obtuse, so I've left my workings in the file too as a macro Macro10 which is a bit less so.

The destination cell doesn't have to be a single cell, if you make it a range it'll fit the range.
Pcnt doesn't have to be less than 1, if you make it greater than one it will overspill the destination range.

Play by adjusting the sizes of the cells in column A and clicking the button.

(Mine too didn't like a shape with zero height or zero width.)

 

[frisbeenut]

Thanks, I will give it a try. I would like to mention the code I wrote that I finally got to work also adds a fixed padding option if the percentage padding's result was not desired. This way either, both or neither padding method can be used. Since the image has a fixed aspect ratio, then the padding will apply to only 2 sides, unless by miracle (or design) the image size ratio exactly matches the cell size ratio.