Help Centering Image VBA

Kristie390

New Member
Joined
Jul 23, 2018
Messages
24
Please help.
I currently am using the below to insert a picture but it is now going top left. I would like to have this resized to auto fit in the cell with the row height 125.
Can someone please help me here? I have researched a few places online and keep getting an error. VBA newbie here..




With Range(BCell)


Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)


.RowHeight = 125

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


myPict.Height = 115


End With
 
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?
 
Upvote 0

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
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:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0
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,
 
Upvote 0
Ok, great, yes- can I please ask to fit the picture to the cell height and allow it to be narrower than the width
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,953
Members
448,535
Latest member
alrossman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top