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.
23933
I want to be like this. the heigh based on the row height and center based on the width.
23934
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/help-forums/excel-vba-macros/1216261-size-of-photo-based-on-the-height-of-row-and-make-center-based-on-the-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
23937
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_19opa01j85j4Hak7SnBsQk2 y1M712O_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.

23942