Πώς θα βάλω πολλαπλές εικόνες μέσα σε excel με zoom

1. File -> Options -> Advanced -> Do not compress images in file

2. Φτιάχνεις ένα ALT + F11 -> Module

Option Explicit

' Ρυθμίσεις thumbnails
Private Const START_COL As String = "G"
Private Const TH_W As Single = 32
Private Const TH_H As Single = 32
Private Const GAP As Single = 6

' Ρυθμίσεις zoom overlay
Private Const MAX_ZOOM_W As Single = 900   'μέγιστο πλάτος zoom (px)
Private Const MAX_ZOOM_H As Single = 650   'μέγιστο ύψος zoom (px)
Private Const DIM_OPACITY As Single = 0.25 'σκοτείνιασμα φόντου

'================= ΕΙΣΑΓΩΓΗ ΕΙΚΟΝΩΝ ΣΤΗ ΓΡΑΜΜΗ =================
Public Sub InsertThumbsForActiveRow()
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim r As Long: r = ActiveCell.Row
    Dim c0 As Long: c0 = ws.Range(START_COL & "1").Column
    Dim cellStart As Range: Set cellStart = ws.Cells(r, c0)

    Dim fd As FileDialog, i As Long
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = True
        .Title = "Διάλεξε εικόνες για τη γραμμή " & r
        .Filters.Clear
        .Filters.Add "Εικόνες", "*.png;*.jpg;*.jpeg;*.bmp;*.gif"
        If .Show <> -1 Then Exit Sub
    End With

    Dim leftPos As Double, topPos As Double
    leftPos = cellStart.Left
    topPos = cellStart.Top + (cellStart.Height - TH_H) / 2

    Application.ScreenUpdating = False
    For i = 1 To fd.SelectedItems.Count
        Dim shp As Shape
        Set shp = ws.Shapes.AddPicture( _
            Filename:=fd.SelectedItems(i), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
            Left:=leftPos, Top:=topPos, Width:=TH_W, Height:=TH_H)
        shp.Name = "Thumb_r" & r & "_" & i
        shp.Placement = xlMoveAndSize
        shp.OnAction = "ThumbZoomOverlay" 'κλικ = zoom overlay
        leftPos = leftPos + TH_W + GAP
    Next i
    Application.ScreenUpdating = True
End Sub

'================= ΔΕΣΙΜΟ ΜΑΚΡΟ ΣΕ ΥΠΑΡΧΟΝΤΑ THUMBNAILS =================
Public Sub WireUpThumbnails()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoPicture Then shp.OnAction = "ThumbZoomOverlay"
    Next shp
    MsgBox "Ορίστηκαν όλα τα thumbnails να κάνουν zoom με κλικ.", vbInformation
End Sub

'================= ΖΟΟΜ ΜΕ ΕΠΙΚΑΛΥΨΗ (ΧΩΡΙΣ ΑΡΧΕΙΑ) =================
Public Sub ThumbZoomOverlay()
    Dim ws As Worksheet: Set ws = ActiveSheet
    If Len(Application.Caller) = 0 Then Exit Sub
    Dim thumb As Shape: Set thumb = ws.Shapes(Application.Caller)

    'Αν υπάρχει ήδη overlay, κλείστο πρώτα
    CloseZoomOverlay ws

    Application.ScreenUpdating = False

    '1) Σκοτείνιασμα φόντου
    Dim dimmer As Shape
    Set dimmer = ws.Shapes.AddShape(msoShapeRectangle, _
        Left:=ActiveWindow.VisibleRange.Left, _
        Top:=ActiveWindow.VisibleRange.Top, _
        Width:=ActiveWindow.VisibleRange.Width, _
        Height:=ActiveWindow.VisibleRange.Height)
    With dimmer
        .Name = "ZoomDim"
        .Fill.ForeColor.RGB = RGB(0, 0, 0)
        .Fill.Transparency = 1 - DIM_OPACITY
        .Line.Visible = msoFalse
        .OnAction = "CloseZoomOverlay"
    End With

    '2) Αντίγραφο της εικόνας – στο αρχικό της μέγεθος για καθαρότητα
    Dim big As Shape
    Set big = thumb.Duplicate
    big.Name = "ZoomPic"
    big.OnAction = "CloseZoomOverlay"
    big.LockAspectRatio = msoTrue

    ' Επανέφερε το αντίγραφο στο embedded original size
    On Error Resume Next
    big.ScaleHeight 1, msoTrue
    big.ScaleWidth 1, msoTrue
    On Error GoTo 0

    ' Τώρα μεγάλωσε με σωστό aspect ratio μέχρι να φτάσει τα όρια
    Dim fW As Double, fH As Double, f As Double
    fW = MAX_ZOOM_W / big.Width
    fH = MAX_ZOOM_H / big.Height
    f = Application.WorksheetFunction.Min(fW, fH)
    big.Width = big.Width * f   'το ύψος προσαρμόζεται λόγω LockAspectRatio

    '3) Κεντράρισμα στο ορατό παράθυρο
    Dim vr As Range: Set vr = ActiveWindow.VisibleRange
    big.Left = vr.Left + (vr.Width - big.Width) / 2
    big.Top = vr.Top + (vr.Height - big.Height) / 2

    big.ZOrder msoBringToFront
    Application.ScreenUpdating = True
End Sub

'Κλείσιμο overlay (καλείται με κλικ στο dimmer ή στην εικόνα)
Public Sub CloseZoomOverlay(Optional ByVal dummy As Variant)
    Dim ws As Worksheet: Set ws = ActiveSheet
    On Error Resume Next
    ws.Shapes("ZoomPic").Delete
    ws.Shapes("ZoomDim").Delete
    On Error GoTo 0
End Sub