Excel Add Image To Cell & View Image It’s Original Size

 

Insert Picture Dynamically In Cell Based On Cell Value 

We have created a template to dynamically add a picture according to the cell value in the worksheet and view this picture in its original size if we want.

When we enter a value in column A, and if there were any pictures that match that value, that picture is added to column E (For example ; if cell A2 text is “A001” or “a001” ,the added image to cell E2 is A001.jpg).
The inserted picture is sized according to cell width and height.It is displayed in the original size when image is clicked.If the image is clicked in its original size, it returns to the cell size.

When the value in any cell of column A was deleted or changed, the image associated with this value is deleted.
In the folder, to find the picture of the entered text to any cell ,we entered the following codes in the Worksheet_Change procedure of the worksheet : ⬇

  Private Sub Worksheet_Change(ByVal Target As Range)
Dim Pic As Picture
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
On Error GoTo son
For Each Pic In ActiveSheet.Pictures
    If Not Application.Intersect(Pic.TopLeftCell, Range(Target.Offset(0, 4).Address)) Is Nothing Then
        Pic.Delete
    End If
Next Pic
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 4).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 2).Height
Selection.ShapeRange.Width = Target.Offset(0, 4).Width
Selection.OnAction = "ViewPicture"

Target.Offset(1, 0).Select
son:
End Sub

As seen in the codes above, ViewPicture macro is triggered when clicking the image on worksheet – Selection.OnAction = "ViewPicture" -.

VBA codes of ViewPicture procedure can be seen below : ⬇

  Sub ViewPicture()
    Dim shp As Shape, rng As String, bu, su As Double
    Dim orignl_big As Single
    Dim shpH As Double, shpOriH As Double

    orignl_big = 1
    Set shp = ActiveSheet.Shapes(Application.Caller)

 rng = shp.TopLeftCell.Address
bu = Range(rng).Offset(0, 0).Width
su = Range(rng).Offset(0, 0).Height

    shpH = shp.Height
    shp.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
    shpOriH = shp.Height
    
    If Round(shpH / shpOriH, 2) = 1 Then
    With shp
            .LockAspectRatio = msoFalse
            .Height = su
            .Width = bu
            .ZOrder msoSendToBack
    End With
   
    Else
        shp.ScaleHeight orignl_big, msoTrue, msoScaleFromTopLeft
        shp.ScaleWidth orignl_big, msoTrue, msoScaleFromTopLeft
        shp.ZOrder msoBringToFront
    End If
End Sub