Help Centering Image VBA

Kristie390

New Member
Joined
Jul 23, 2018
Messages
24
The way the code works now seems to be fine, but it is not doing what it intends to do from what I can see.
The image should be auto-fitting inside of the B cell, correct?
 

Some videos you may like

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,746
Office Version
2010
Platform
Windows
I don't know what "auto-fitting" means. Should it be the same height and width as the cell? Isn't that likely to stretch the picture one way or the other?
 
Last edited:

Kristie390

New Member
Joined
Jul 23, 2018
Messages
24
In the code I had previously, the rows were set to a height of 125 and the images were set to a height of 115 I believe. It was resizing them and i was not seeing any issues with the pictures being stretched. Maybe it was something in the code i was overlooking that was put in there.
The issue I had was that the code set to top left justify the image.
Is there something I can use besides this to center the image and then I can go back to the row height and image height I had before ? It sounds like it could be easier? I am not sure.

.RowHeight = 125

myPict.Top = .Top
myPict.Left = .Left
myPict.Placement = xlMoveAndSize


myPict.Height = 115
 

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,746
Office Version
2010
Platform
Windows
Code:
Sub Kristie()
  ' inserts the picture files listed in col A into the workbook,
  ' sizes then to the same height and width as the cell in col B,
  ' and centers them in col B

  Const sPath       As String = "S:\Images\Casio"
  'Const sPath       As String = "C:\Users\shg\Pictures\shg\"
  Dim cell          As Range
  Dim sFile         As String
  Dim oPic          As Picture

  For Each cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    sFile = sPath & cell.Text & ".jpg"
    If Len(Dir(sFile)) Then
      Set oPic = ActiveSheet.Pictures.Insert(sFile)

      With cell.Offset(, 1)
        oPic.Height = .Height
        oPic.Width = .Width
        oPic.Top = .Top + .Height / 2 - oPic.Height / 2
        oPic.Left = .Left + .Width / 2 - oPic.Width / 2
      End With
    Else
      cell.Select
      MsgBox sFile & " not found"
    End If
  Next cell
End Sub
 

Kristie390

New Member
Joined
Jul 23, 2018
Messages
24
Thank you for the revision. I do see that these are for the most part not fitting inside of the cells . They overlap . Shouldnt they be the same size as the cell in B?
 

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,746
Office Version
2010
Platform
Windows
Code:
Sub Kristie()
  ' inserts the picture files listed in col A into the workbook,
  ' sizes them to fit the position, height, and width of the
  ' adjacent cell in col B

  Const sPath       As String = "S:\Images\Casio"
  'Const sPath       As String = "C:\Users\shg\Pictures\shg"
  Dim cell          As Range
  Dim sFile         As String
  Dim oPic          As Picture

  For Each cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    sFile = sPath & cell.Text & ".jpg"
    If Len(Dir(sFile)) Then
      Set oPic = ActiveSheet.Pictures.Insert(sFile)
      oPic.ShapeRange.LockAspectRatio = msoFalse

      With cell.Offset(, 1)
        oPic.Height = .Height
        oPic.Width = .Width
        
        oPic.Top = .Top + .Height / 2 - oPic.Height / 2
        oPic.Left = .Left + .Width / 2 - oPic.Width / 2
      End With
    Else
      cell.Select
      MsgBox sFile & " not found"
    End If
  Next cell
End Sub
 

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,746
Office Version
2010
Platform
Windows
If you want no overlap of the cell edges, it's possible to

o fit the picture to the cell height and allow it to be narrower than the width, or

o fit it to the cell width and allow it to be shorter than the height.

Right now, it stretches to fit,
 

Kristie390

New Member
Joined
Jul 23, 2018
Messages
24
Ok, great, yes- can I please ask to fit the picture to the cell height and allow it to be narrower than the width
 

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,746
Office Version
2010
Platform
Windows
That's not two choices, it's one. If you always scale it to the height, it may overlap the width, and vice versa. The option from what I posted is to scale it upward until it meets the first dimension.
 

Watch MrExcel Video

Forum statistics

Threads
1,099,018
Messages
5,466,066
Members
406,462
Latest member
I10V3xl

This Week's Hot Topics

Top