Insert Centered & resize a picture in Excel with VBA

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
246
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Found this code from Barb Henderson.
Works great. However, I want to center the photo within the cell. I tried many different variations and it will not center in the cell, but in the middle of the entire sheet.
How to center the photo in the absolute middle of the cell and for photos to actually show when the excel file is viewed by others? Nobody can see the photos now because the path is on my computer.

VBA Code:
Sub Picture()
Dim pictname As String
Dim pastehere As Range
Dim pasterow As Long
Dim x As Long
Dim lastrow As Long

lastrow = Worksheets("sheet1").Range("B1").CurrentRegion.Rows.Count
x = 2
For x = 2 To lastrow
Set pastehere = Cells(x, 1)
pasterow = pastehere.Row
Cells(pasterow, 1).Select 'This is where picture will be inserted

pictname = Cells(x, 2) 'This is the picture name
ActiveSheet.Pictures.Insert("C:\Users\Barb\Pictures\demo\" & pictname & ".jpg").Select 'Path to where pictures are stored

With Selection

.Left = Cells(pasterow, 1).Left
.Top = Cells(pasterow, 1).Top

.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With

Next

End Sub
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
I seem there are two questions in your message:
1) how do I set the images centered with the hosting cell
2) how do I embed the imeges into the workbook, so that the same images can be viewed on someone else pc

For problem #2, you should use Shapes.AddPicture (rather than Pictures.Insert)
For problem #1, we need to set the position considering the cell and picture sizes

Thus, for example:
Code:
Sub Picture()
Dim pictname As String
Dim pastehere As Range
Dim pasterow As Long
Dim x As Long
Dim lastrow As Long, cPic

lastrow = Worksheets("sheet1").Range("B1").CurrentRegion.Rows.Count
x = 2
For x = 2 To lastrow
    Set pastehere = Cells(x, 1)
    pasterow = pastehere.Row
    Cells(pasterow, 1).Select 'This is where picture will be inserted
    pictname = Cells(x, 2) 'This is the picture name
    Set cPic = ActiveSheet.Shapes.AddPicture("C:\Users\Barb\Pictures\demo\" & pictname & ".jpg", False, True, PosizLeft, PositTop, True, True)
'    ActiveSheet.Pictures.Insert("C:\Users\Barb\Pictures\demo\" & pictname & ".jpg").Select 'Path to where pictures are stored
    With cPic
        .LockAspectRatio = msoFalse
        .Height = 80#
        .Width = 80#
        .Left = Cells(pasterow, 1).Left + Cells(pasterow, 1).Width / 2 - .Width
        .Top = Cells(pasterow, 1).Top + Cells(pasterow, 1).Height / 2 - .Height
    End With
Next x
Set cPic = Nothing
End Sub

Try...
 
Upvote 0
I seem there are two questions in your message:
1) how do I set the images centered with the hosting cell
2) how do I embed the imeges into the workbook, so that the same images can be viewed on someone else pc

For problem #2, you should use Shapes.AddPicture (rather than Pictures.Insert)
For problem #1, we need to set the position considering the cell and picture sizes

Thus, for example:
Code:
Sub Picture()
Dim pictname As String
Dim pastehere As Range
Dim pasterow As Long
Dim x As Long
Dim lastrow As Long, cPic

lastrow = Worksheets("sheet1").Range("B1").CurrentRegion.Rows.Count
x = 2
For x = 2 To lastrow
    Set pastehere = Cells(x, 1)
    pasterow = pastehere.Row
    Cells(pasterow, 1).Select 'This is where picture will be inserted
    pictname = Cells(x, 2) 'This is the picture name
    Set cPic = ActiveSheet.Shapes.AddPicture("C:\Users\Barb\Pictures\demo\" & pictname & ".jpg", False, True, PosizLeft, PositTop, True, True)
'    ActiveSheet.Pictures.Insert("C:\Users\Barb\Pictures\demo\" & pictname & ".jpg").Select 'Path to where pictures are stored
    With cPic
        .LockAspectRatio = msoFalse
        .Height = 80#
        .Width = 80#
        .Left = Cells(pasterow, 1).Left + Cells(pasterow, 1).Width / 2 - .Width
        .Top = Cells(pasterow, 1).Top + Cells(pasterow, 1).Height / 2 - .Height
    End With
Next x
Set cPic = Nothing
End Sub

Try...

Anthony47 Thank you for providing the script. I ran it a few times and the photos will not go into the corresponding cells. It floats in the correct column, just not in the correct cell.​

 
Upvote 0
I ran it a few times and the photos will not go into the corresponding cells. It floats in the correct column, just not in the correct cell.
I am afraid that both positions, column and row, are wrong; my best option is this modification:
VBA Code:
        .Left = Cells(pasterow, 1).Left + Cells(pasterow, 1).Width / 2 - .Width/2
        .Top = Cells(pasterow, 1).Top + Cells(pasterow, 1).Height / 2 - .Height/2

Retry...
 
Upvote 0
Solution
I am afraid that both positions, column and row, are wrong; my best option is this modification:
VBA Code:
        .Left = Cells(pasterow, 1).Left + Cells(pasterow, 1).Width / 2 - .Width/2
        .Top = Cells(pasterow, 1).Top + Cells(pasterow, 1).Height / 2 - .Height/2

Retry...
BINGO!!!
Thank you for your quick reply!
 
Upvote 0

Forum statistics

Threads
1,223,894
Messages
6,175,252
Members
452,623
Latest member
Techenthusiast

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