Insert Centered & resize a picture in Excel with VBA

[NeoSez]

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.

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

 

[Anthony47]

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:

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]

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:

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]

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:

        .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...

 

[NeoSez]

I am afraid that both positions, column and row, are wrong; my best option is this modification:

        .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!