Inserting Image

[royhern]

Just wondering is there a way to insert a picture in select group cells and automatic
having the picture to auto adjust width and height within the group of cells.

Thanks, Roy

 

[Joe Was]

Directly No, but if you use a UserForm then yes.

If you use the photo as a shape then you will not need to use the UserForm.

This code will build a photo library on a sheet, using the photo shape. JSW

Sub s_Photos()
'Adds a photo below the last photo if any.

Application.ScreenUpdating = False
Range("D65536").End(xlUp).Offset(4, -2).Select
ActiveCell.RowHeight = 118.5
ActiveCell.ColumnWidth = 32.43

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
myFile = Application.InputBox("Enter your, ""Drive:PathFile.jpg"" for your Photo." _
& Chr(13) & Chr(13) & " Like, C:MyFilesJSWExcelFOREST03.JPG" & Chr(13) & Chr(13) _
& " In the box below!", Title:="Please indicate the photo location!" _
, Default:="C:MyFilesJSWExcelFOREST03.JPG")
On Error GoTo Kil
'ActiveSheet.Pictures.Insert("C:MyFilesJSWExcelFOREST03.JPG").Select
ActiveSheet.Pictures.Insert(myFile).Select
Selection.ShapeRange.ScaleHeight 0.34, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 0.33, msoFalse, msoScaleFromTopLeft
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With
ActiveCell.Offset(0, 2).Select
Selection.Interior.ColorIndex = xlNone
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
ActiveCell.FormulaR1C1 = "Photo: "
With ActiveCell.Characters(Start:=1, Length:=8).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A1").Select
Application.ScreenUpdating = True
Kil:
Range("A1").Select
Application.ScreenUpdating = True

End Sub