Soru Klasörden resim getirmek

[tahsinanarat]

Resim getirme ile ilgili çok sayıda örnek dosyalarım var, ama bu biraz farklı ilk defa sayfada diğer sayfadan alacağı bilgilerle C:\fotoğraflar\ klasöründe resim getirmeye çalıştım, ancak başaramadım.

Örnek dosyamda Şema adlı sayfamda birleştirilmiş hücrelerle yapılmış bir hücreye Data adlı sayfanın c sütunundaki (formüllü) eşleşen hücrenin sağındaki (d sütununda) tc kimlik numarasına göre resmin görünmesini, başka hücreye geçildiğinde ise resmin kapanarak o hücreye ait eşleşen resmin görünmesini istiyorum, yani hücre seçildiğinde resim görünsün. Bırakıldığında resim kaybolsun.

 

[Orion1]

Buyurun.
Dosyanız ektedir.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim k As Range
On Error Resume Next
For Each resimm In ActiveSheet.Pictures
    resimm.Delete
Next
Set k = Sheets("data").Range("C:C").Find(Target.Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    ActiveSheet.Pictures.Insert ("C:\fotoğraflar\" & k.Offset(0, 1).Value & ".jpg")
End If
End Sub

 

[tahsinanarat]

Sn. Orion hocam elinize sağlık çok teşekkür ediyorum, resim boyutları farklı farklı geliyor, aynı boyutta gelmesini istiyorum. Bu konu da yardımınız olabilir mi. Teşekkürler.

 

[Orion1]

Buyurun.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim k As Range, rsm
On Error Resume Next
For Each resimm In ActiveSheet.Pictures
    resimm.Delete
Next
Set k = Sheets("data").Range("C:C").Find(Target.Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    Set rsm = ActiveSheet.Pictures.Insert("C:\fotoğraflar\" & k.Offset(0, 1).Value & ".jpg")
    rsm.ShapeRange.LockAspectRatio = msoFalse
    rsm.Height = Target.Height
   rsm.Width = Target.Width
   Set rsm = Nothing
End If
Set k = Nothing
End Sub

 

[tahsinanarat]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim k As Range, rsm
On Error Resume Next
For Each resimm In ActiveSheet.Pictures
resimm.Delete
Next
Set k = Sheets("data").Range("C:C").Find(Target.Value, , xlValues, xlWhole)
If Not k Is Nothing Then
Set rsm = ActiveSheet.Pictures.Insert("C:\foto\" & k.Offset(0, 1).Value & ".jpg")
rsm.ShapeRange.LockAspectRatio = msoFalse
rsm.ShapeRange.Height = 140
rsm.ShapeRange.Width = 120
' rsm.Height = Target.Height
' rsm.Width = Target.Width
Set rsm = Nothing
End If
Set k = Nothing
End Sub

Hocam bu şekilde istediğim ebatlara ulaşabildim. Çok Teşekkür ediyorum. Hayırlı geceler dilerim.

 

[Orion1]

Rica ederim.
İyi çalışmalar.