Ataşare poze în fişier

[dobre ionel]

Bună seara.
Vă rog să mă ajutaţi în următoarea situaţie:
Am găsit pe net următorul cod ( se află în fişierul ataşat ) care introduce o poză în fişier. Se poate modifica pentru a introduce trei poze în acelaşi fişier?
Vă mulţumesc de ajutor. O seară bună

[Dr.Windows]

Cand este vorba de VBA, orice se poate.

Codul de mai jos adauga/modifica 3 imagini si se bazeaza pe urmatoarele:
1. Numele imaginii se preia de pe coloana J, extensia se adauga automat si este "fixata" ca PNG.
Se poate extinde rangeul J1:J3 cu oricat de multe poze sunt necesare

2. Imaginile trebuie sa existe in aceleasi folder cu fisierul Excel.
Pentru o administrare mai usoara, daca se folosesc mai multe imagini, se pot pune intr-un folder separat care sa existe in aceeasi locatie ca si fisierul Excel si atunci trebuie modificata linia:

Cod: Selectaţi tot

    cale = ThisWorkbook.Path & "\" & Target.Value & ".PNG"

cu

Cod: Selectaţi tot

    cale = ThisWorkbook.Path & "\Imagini\" & Target.Value & ".PNG"

3. Se foloseste o zona de "referinta" pentru a stabili dimensiunea imaginii si pozitionarea ei, si se poate modifica cu orice zona, acum este "B2:E7"

Restul sunt mici detalii de "ajustare" si "cosmetizare" dar codul este urmatorul:

Cod: Selectaţi tot

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Foto As Object, Sus As Double, Stanga As Double, Lungime As Double, Inaltime As Double
    Dim cale As String
    Application.ScreenUpdating = False
    On Error Resume Next
    If Intersect(Target, Range("J1:J3")) Is Nothing Then Exit Sub
    Me.Shapes("Foto" & Target.Row).Delete
    cale = ThisWorkbook.Path & "\" & Target.Value & ".PNG"
    Set Foto = Me.Pictures.Insert(cale)
    With Range("b2:e7") 'zona de referinta unde se va pozitiona imaginea
        Sus = .Top
        Stanga = .Left
        Lungime = .Offset(0, .Columns.Count).Left - .Left
        Inaltime = .Offset(.Rows.Count, 0).Top - .Top
    End With
    With Foto
        .Name = "Foto" & Target.Row
        .ShapeRange.LockAspectRatio = msoFalse  'Daca aspectul va fi proportional se seteaza ori intaltimea ori latimea
        .Top = Sus + Inaltime * (Target.Row - 1)
        .Left = Stanga
        .Width = Lungime
        .Height = Inaltime - 2  'scurteaza intaltimea cu 2 puncte ca sa se vada mai bine pozele
    End With
    Set Foto = Nothing
    Application.ScreenUpdating = True
End Sub

[dobre ionel]

Bună seara.
Mulţumesc Dr.Windows, funcţionează perfect.
Mulţumesc şi o seară bună