size of photo based on the height of row and make center based on the column width

[forerver]

hi guys,

I need you help regarding the fit of photo based on the column height and make center the photo based on the width. I have a code but I try to figure out the size of photo but I cannot fix. here the result of photo become stretch.
Screen Shot 2019-03-21 at 12.41.05 AM.jpg
I want to be like this. the heigh based on the row height and center based on the width.
Screen Shot 2019-03-21 at 1.01.49 AM.jpg
here the code

Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
Dim addr As Variant
Dim hPictureLocations As Variant
Dim i As Long
Dim lastRow As Long
    Const filepath As String = "D:\royal_plaza_wincash\"  '*   this is my test folder
    'Const filepath As String = "C:\Users\drawing\Desktop\New folder\"
    'Const filepath As String = "X:\Miscellany\"     'How I tested
lastRow = WorksheetFunction.Max(11, ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row)
If Not Intersect(Target, Range("C2:C" & lastRow)) Is Nothing Then
    If Dir(filepath & Target & ".jpg") <> "" Then   '*  verify that the file exists
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        With Target.Offset(0, -1)
            On Error Resume Next
            Me.Shapes("PictureAt" & .Address).Delete
            On Error GoTo 0
            Set shp = Me.Shapes.AddPicture(filepath & Target & ".jpg", msoFalse, msoCTrue, .Left, .Top, .Width, .Height)
            shp.Name = "PictureAt" & .Address
        End With
    End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True


If Not Intersect(Target, Range("C2:C" & lastRow)) Is Nothing Then
        With Target.Offset(0, -1)
            On Error Resume Next
            Me.Shapes("PictureAt" & .Address).Delete
            Err.Clear
            On Error GoTo 0
             If Dir(filepath & Target & ".jpg") <> "" Then
                Set shp = Me.Shapes.AddPicture(filepath & Target & ".jpg", msoFalse, msoCTrue, .Left, .Top, .Width, .Height)
                shp.Name = "PictureAt" & .Address
                GoSub setShapeSize
             Else
                If Dir(filepath & NOPHOTO & ".jpg") <> "" Then
                Set shp = Me.Shapes.AddPicture(filepath & "NOPHOTO.jpg", msoFalse, msoCTrue, .Left, .Top, .Width, .Height)
                shp.Name = "NOPHOTO"
                GoSub setShapeSize
                Else
                    With Target.Offset(0, -1)
                    .Value = "NO PHOTO" & Chr(10) & "AVAILABLE"
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                End With
                End If
             End If
        End With
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub


setShapeSize:
With shp
    .LockAspectRatio = msoTrue
    .Top = Target.Offset(0, -1).Top
    .Left = Target.Offset(0, -1).Left
    .Width = Target.Offset(0, -1).Width
    .Height = Target.Offset(0, -1).Height


End With
End If
Return


End Sub

[Kenneth Hobs]

Welcome to the forum!

Cross-posted: https://www.ozgrid.com/forum/forum/h...e-column-width

You should be able to adapt this. This assumes a landscape oriented picture. This means that h/w <= 1. If you have portrait pics, the ratio of h/w is >= 1. I have a routine that applies the right correction that I can adapt if needed.

Sub AddPic()  
  Dim fn$, c As Range, s As Shape, p As Picture, w As Single, h As Single, wS As Single
  
  fn = "C:\myfiles\pics\phone\20190321\20190309_175242.jpg"
  Set c = [A1]
  
  With ActiveSheet
    'Get pic's hxw
    Set p = .Pictures.Insert(fn)  'Linked pic
    h = p.Height
    w = p.Width
    'hxw=594x792. 30x40" inserted as 8.25/11" = 792/1056 pixels, All ratio h/w=0.75. 96 pixels/1"
    'Debug.Print h, w
    p.Delete
    
    'AddPicture as shape, linked pic or not linked as in this use.
    wS = c.Height * w / h
    Set s = .Shapes.AddPicture(fn, msoFalse, msoCTrue, c.Left + c.Width / 2 - wS / 2, c.Top, wS, c.Height)
  End With
End Sub

[forerver]

Thanks you for reply and for you help. But I don't where I can add the code. I try to the code based on reply but the picture not proportion. like this below
Screen Shot 2019-03-21 at 11.53.45 PM.jpg
The Code i like this. Set shp = Me.Shapes.AddPicture(filepath & Target & ".jpg", msoFalse, msoTrue, .Left, .Top, .Width / 2, .Height)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
Dim addr As Variant
Dim hPictureLocations As Variant
Dim i As Long
Dim lastRow As Long
    Const filepath As String = "D:\royal_plaza_wincash\"  '*   this is my test folder
    'Const filepath As String = "C:\Users\drawing\Desktop\New folder\"
    'Const filepath As String = "X:\Miscellany\"     'How I tested
lastRow = WorksheetFunction.Max(11, ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row)
If Not Intersect(Target, Range("C2:C" & lastRow)) Is Nothing Then
    If Dir(filepath & Target & ".jpg") <> "" Then   '*  verify that the file exists
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        With Target.Offset(0, -1)
            On Error Resume Next
            Me.Shapes("PictureAt" & .Address).Delete
            On Error GoTo 0
            Set shp = Me.Shapes.AddPicture(filepath & Target & ".jpg", msoFalse, msoCTrue, .Left, .Top, .Width, .Height)
            shp.Name = "PictureAt" & .Address
        End With
    End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True


If Not Intersect(Target, Range("C2:C" & lastRow)) Is Nothing Then
        With Target.Offset(0, -1)
            On Error Resume Next
            Me.Shapes("PictureAt" & .Address).Delete
            Err.Clear
            On Error GoTo 0
             If Dir(filepath & Target & ".jpg") <> "" Then
                Set shp = Me.Shapes.AddPicture(filepath & Target & ".jpg", msoFalse, msoTrue, .Left, .Top, .Width / 2, .Height)
                shp.Name = "PictureAt" & .Address
                GoSub setShapeSize
             Else
                If Dir(filepath & NOPHOTO & ".jpg") <> "" Then
                Set shp = Me.Shapes.AddPicture(filepath & "NOPHOTO.jpg", msoFalse, msoCTrue, .Left, .Top, .Width, .Height)
                shp.Name = "NOPHOTO"
                GoSub setShapeSize
                Else
                    With Target.Offset(0, -1)
                    .Value = "NO PHOTO" & Chr(10) & "AVAILABLE"
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                End With
                End If
             End If
        End With
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub


setShapeSize:
With shp


  ' .LockAspectRatio = msoTrue
  ' .Top = Target.Offset(0, -1).Top / 2
   ' .Left = Target.Offset(0, -1).Left
 ' .Width = Target.Offset(0, -1).Width / 2
 ' .Height = Target.Offset(0, -1).Height / 2
 '  ' shp.ScaleHeight 1.75, msoFalse
End With
Return


End Sub

[Kenneth Hobs]

My code is very simple to test. In a new sheet or blank cell (change A1 if needed):

1. Resize row height of cell to orient to to suit.
2. Change the value of fn to a file on your drive.
3. Run the code.

The concept in my code was commented.
1. Insert a picture to get the ratio data.
2. Delete the inserted picture.
3. AddPicture making use of the ratio data.

Of course the limitation of landscape still applies in code for post #2. If portrait, you can tell by the ratio, w/h, as I showed in the comment. If portrait ratio then the code for wS would be:

wS = c.Height / w / h

I can do the ratio check for you as I explained. First, see if landscape pics "fit right". If cell dimensions are too far from the proportions of the pic, issues might arise when you hold height as the limiting factor.

Note: Unless your cell dimension ratio is the same as the pic's ratio, the pic will never fully fit in the cell like your "supposed to" pic shows. That pic looks like it is a fully fitted pic.

[Aussiebear]

Might be a lot easier if you attach a sample workbook for Kenneth to test on.

[Kenneth Hobs]

I may try to modify your posts #'s 1 and 3 code but I am unsure of your goal(s). It looks like you are doing two range iterations in it. If you attach a file, click the Go Advanced button in bottom right of reply box and then Manage Attachments link below that reply box.

For giggles, in this example, I made the routine a bit faster using WIA rather than inserting a picture, getting wxh, and deleting it. Some other 3rd parties applications like IrfanView can get the same wxh information.

'WIA examples, https://docs.microsoft.com/en-us/windows-hardware/drivers/image/windows-image-acquisition-drivers
Sub AddPic2()
  Dim fn$, c As Range, s As Shape, w As Single, h As Single, wS As Single
  'https://docs.microsoft.com/en-us/previous-versions/windows/desktop/wiaaut/-wiaaut-imagefile#properties
  'Dim Img as object  'Late Binding
  'Tools > References > Microsoft Windows Image Acquisition Library v2.0 > OK
  Dim img As ImageFile  'Early Binding
  
  'fn = "C:\myfiles\pics\phone\20190321\20190309_175242.jpg"  'Work
  fn = "C:\Users\lenovo1\Dropbox (Personal)\_Excel\pics\Picture 2.jpg"  'Home
  'Debug.Print Dir(fn) <> ""
  Set c = [A1]


  'Get pic's hxw using WIA
  Set img = CreateObject("WIA.ImageFile")
  img.LoadFile fn
  h = img.Height  'pixels
  w = img.Width 'pixels
  'hxw=594x792. 30x40" inserted as 8.25/11" = 792/1056 pixels, All ratio h/w=0.75. 96 pixels/1"
  'Debug.Print h, w
  Set img = Nothing
  
  'AddPicture as shape, linked pic or not linked as in this use.
  wS = c.Height * w / h
  Set s = ActiveSheet.Shapes.AddPicture(fn, msoFalse, msoCTrue, c.Left + c.Width / 2 - wS / 2, c.Top, wS, c.Height)
End Sub

[Kenneth Hobs]

Here is the modification of your code for one section using the WIA method with the correction for Portrait vs. Landscape. I included links to the two example pics: Apple.jpg and Apples.jpg with the two orientations.

'Apple, landscape, https://www.google.com/search?tbs=sbi:AMhZZius98SuAhrkOQF9fV6kTzQL-3UCNRACEMTUZpoSZQZ33wedDo3zDhrAx9PLRJzGkgDsdCwxiIGA2NFlcLs7pYb86j-7bnpMfhVeOQCGxi8e7IrZwI590y6A2YIgTqt1KqJBFo5Ip8EbZX_19opa01j85j4Hak7SnBsQk2y1M712O_1ybQR-ouWQbik6LDa_1cU2a_10dAN4Yv8Bqld510VzkqzX61lPCl4RELtQYkloCy-1ngZ6ZctNGVjEVrgACe2COkN6Oe-VtdlMTslYSA9-xZLmnvfog0IWa_1WZfHS1OPdt85idW3vqUWCeDjsQYnQAFoLXJBIdst3J6OQB-i3lY80R_1XkLEQ&btnG=Search%20by%20image&hl=en
'Apples, portrait, https://www.google.com/search?q=apple.jpg&rlz=1C1CHBF_enUS700US700&tbm=isch&source=iu&ictx=1&fir=SF1rgUNF6SuIsM%253A%252CvbzI2psvbsyBhM%252C_&vet=1&usg=AI4_-kTvnHzhG5kAYSdkSyvst1ln-WkGMw&sa=X&ved=2ahUKEwiVt9KLnJfhAhXBMn0KHRQpDdwQ9QEwAHoECAcQBA#imgrc=GbHQHgxOSiOOwM:&vet=1


Private Sub Worksheet_Change(ByVal Target As Range)
  Dim shp As Shape, i As Long, lastRow As Long
  Dim filepath$, iR As Range, iC As Range
  Dim fn$, img As ImageFile, w As Single, h As Single, wS As Single
  
  filepath = ThisWorkbook.Path & "\Fruits\"
  'Const filepath As String = "D:\royal_plaza_wincash\"  '*   this is my test folder
  'Const filepath As String = "C:\Users\drawing\Desktop\New folder\"
  'Const filepath As String = "X:\Miscellany\"     'How I tested
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  
  lastRow = Cells(Rows.Count, "C").End(xlUp).Row
  Set iR = Intersect(Target, Range("C2", Cells(lastRow, "C")))
  
  If Not iR Is Nothing Then
      For Each iC In iR
        fn = filepath & iC & ".jpg"
        If Dir(fn) <> "" Then   '*  verify that the file exists
          With iC.Offset(0, -1)
            On Error Resume Next
            Me.Shapes("PictureAt" & .Address).Delete
            On Error GoTo 0
            'Get pic data:
            Set img = CreateObject("WIA.ImageFile")
            img.LoadFile fn
            h = img.Height  'pixels
            w = img.Width 'pixels
            Set img = Nothing
            
            'Set the shapes width (wS) using the "right" ratio:
            If w / h < 1 Then
              wS = .Height * w / h 'landscape
              Else
              wS = .Height * h / w 'Portait
            End If
            
            Set shp = ActiveSheet.Shapes.AddPicture( _
              fn, msoFalse, msoCTrue, .Left + .Width / 2 - wS / 2, .Top, wS, .Height)
            shp.Name = "PictureAt" & .Address
          End With
        End If
      Next iC
  End If
  
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

[forerver]

thanks you again for you help. but I found the error.

Screen Shot 2019-03-23 at 9.05.02 AM.jpg