Insert Centered & resize a picture in Excel with VBA

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
164
Office Version
  1. 2019
  2. 2010
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

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
2,278
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...
 

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
164
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
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.​

 

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
2,278
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...
 
Solution

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
164
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
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!
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,151,972
Messages
5,767,402
Members
425,410
Latest member
SmittyT

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
Top