Forum - VBA Εισαγωγή εικόνας και προσαρμογή της

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [VBA] Εισαγωγή εικόνας και προσαρμογή της (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/3533-eisagogi-eikonas-kai-prosarmogi-tis.html)

Εισαγωγή εικόνας και προσαρμογή της

Καλησπέρα στην παρέα του φόρουμ.
Να ευχηθώ και καλή χρονιά με υγεία σε όλους, καθώς είναι το πρώτο θέμα για φέτος που ανοίγω.

Θέλω να εισάγω σε φύλλο εργασίας εικόνες (.jpg) αντλώντας την πληροφορία για τη θέση στην οποία βρίσκεται αυτή από το περιεχόμενο ενός κελιού. Για παράδειγμα το κελί Α1 περιέχει την ονομασία του αρχείου με όλη τη διαδρομή.

Την εικόνα θέλω να την εισάγω π.χ. στο κελί Β1 στο οποίο το έχω ήδη καθορίσει ορισμένες διαστάσεις για το ύψος και πλάτος του. Το ζητούμενο μου είναι να εισαχθεί η εικόνα στο Β1 παίρνοντας αυτόματα το ανάλογο μέγεθος, ώστε αυτή να εφαρμόζει ακριβώς σύμφωνα με τις διαστάσεις του κελιού.

Ευχαριστώ εκ των προτέρων για κάθε βοήθεια.

Φιλικά
Δημήτρης

Καλησπέρα
Με βάση το ζητούμενο, το κελί a1, περιέχει όλη την διαδρομή της εικόνας που θα εισαχθεί.
Δηλαδή:
Διαδρομή φακέλου & όνομα εικόνας & κατάληξη.
Στο κελί b1, έχουμε προσαρμόσει τις διαστάσεις, κατά την κρίση μας και κατά τις ανάγκες της εργασίας μας.
Θέλουμε:
Να εισαχθεί, στο b1, η εικόνα με διαδρομή a1 και
να προσαρμοστεί στις διαστάσεις του κελιού b1.

Σε μια λειτουργική μονάδα αντιγράφουμε τον κώδικα:

Κώδικας:

Sub InsertPictures()

    Application.ScreenUpdating = False

    Dim myPath As String

    myPath = Sheet2.Range("a1")

    Dim Pic As Picture

    Dim obj As Variant

    Dim Pict As Variant

    'Διαγράφει παλιές εικόνες από το φύλλο

    Set obj = Sheet2.Shapes

    For Each Pict In obj

        If Left(Pict.Name, 7) = "Picture" Then

            Pict.Delete

        End If

    Next Pict

    'Εισαγωγή νέας εικόνας

    Set Pic = Sheet2.Pictures.Insert(myPath)

    'Προσαρμογή στο κελί b1

    With Pic

        .ShapeRange.LockAspectRatio = msoFalse

        .Height = Sheet2.Cells(1, 2).Height

        .Width = Sheet2.Cells(1, 2).Width

        .Top = Sheet2.Cells(1, 2).Top

        .Left = Sheet2.Cells(1, 2).Left

        .Placement = xlMoveAndSize

    End With

    'Άδειασμα και έξοδος

    Set Pic = Nothing

End Sub

*Sheet2. = το κωδικό όνομα του φύλλου
**Αν πρέπει στο φύλλο, να υπάρχουν και αλλού σχήματα ή εικόνες,
να μετονομαστούν σε κάτι που δεν περιέχει Picture χ

Σε ευχαριστώ πολύ Σπύρο.
Όπως πάντα άψογος. Να είσαι καλά.

Φιλικά
Δημήτρης