İki Resim Getirme

[zerali]

Arkadaşlar yapacağım Babalar günü etkinliği için babalara sürpriz olsun diye her öğrenciye bir şiir yazdırıp babasıyla çekilmiş 2 fotoğrafını koyacağım bir belge hazırlayacağım. Bu belgede ismi seçtiğimde ismi resmi getir düğmesine bastığımda resimlerini getirmesini istiyorum. Bu çalışmayı yapmakta yardımcı olabilirseniz çok memnun olurum .şimdiden çok teşekkürler

https://www.dosya.tc/server34/2q7xkp/mel_babammm.xlsm.html

 

[EmrExcel16]

Merhaba , sayfanın kod bölümüne yapıştırıp deneyiniz..

Düğme kullanmanıza gerek kalmasın diye isim değiştiğinde resim otomatik geliyor.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("O3")) Is Nothing Then Exit Sub
    Dim Resim, ResimAdi, Adress, ResAdres
    On Error Resume Next
    For Each Resim In ActiveSheet.Shapes
        Adress = Resim.TopLeftCell.Address
        If [C10].Address = Adress Or [H10].Address = Adress Then
            If Resim.Type <> 8 Then
                Resim.ShapeRange.LockAspectRatio = msoFalse
                Resim.Delete
            End If
        End If
    Next
    For Each Resim In Sheets("resim").Shapes
        Adress = Resim.TopLeftCell.Column
        ResimAdi = Sheets("resim").Cells(Resim.TopLeftCell.Row, 7).Value
        If ResimAdi = [O3] Then
            Resim.Copy
            If Adress = 1 Then
                ActiveSheet.Paste Destination:=Cells(10, 3)
                ResAdres = Cells(10, 3).Column
            Else
                ActiveSheet.Paste Destination:=Cells(10, 8)
                ResAdres = Cells(10, 8).Column
            End If
            With Cells(10, ResAdres)
                Selection.ShapeRange.LockAspectRatio = msoFalse
                Selection.Height = .MergeArea.Height + 110
                Selection.Width = .MergeArea.Width + 100
                Selection.Top = .Top + 2
                Selection.Left = .Left + 2
                Selection.Placement = xlMoveAndSize
            End With
        End If
        [O3].Select
    Next
End Sub

 

[zerali]

EmrExcel16 hocam kodu yapıştırdım ismi değiştirdim ama resim gelmedi yanlış bir şey mi yaptım

 

[EmrExcel16]

"Sayfanın" kod bölümüne yapıştırmanız gerekiyor , belki burada karıştırmış olabilirsiniz .

 

[zerali]

Evet karıştırmışım şimdi yapıştırdım oldu. Çok teşekkür ederim Emeğinize sağlık. 41 öğrencim var Bunun için bir değişiklik yapmama gerek var mı acaba?

 

[EmrExcel16]

Rica ederim , öğrenci sayısı önemli değil bu şekilde kullanabilirsiniz.

 

[zerali]

Çok teşekkürler

 

[zerali]

EmrExcel16 hocam son bir şey daha sormak istiyorum Resimlerin boyutunu biraz daha büyütmek için ne yapmam gerekir?

 

[EmrExcel16]

Selection.Height = .MergeArea.Height + 110
Selection.Width = .MergeArea.Width + 100

Kod' un bu bölümündeki rakamlar ile oynayarak boyutunu değiştirebilirsiniz.

 

[zerali]

Bilgilendirme için çok sağolun hocam