Excel'de klasörden resim alma

[bugur]

Merhaba;

Araştırdım ama tam işimi görecek bir yol bulamadım. İhtiyacım olan şey şudur:

excel dosyasında teklif hazırlıyorum.

A sütununda ürün kodu örnegin TAA110 yazıyoruz
B sütununda "C:\urunler\" klasöründe ürün koduyla aynı isimde jpg dosyalarından resim yerleştirilecek (yapamadığım budur)

A4 hücresine örneğin TAA110 yazdığımda enter a basınca otomatik olarak B4 hücresine "C:\urunler\" klasöründeki TAA110.jpg isimli dosyanın resmi gelmelidir.

Bunu yaparken aynı zamanda excel hücresini de örneğin 120*120 piksel ölçülerde otomatik ayarlayarak resmi yatay ve düşey ortalayarak sığdırma yapabilmelidir.

bu işlemler A4, A5, A6 ... şeklinde 10-20 satırda (teklif içerik ürünleri) da işlev görecek şekilde tasarlanması gerekmektedir. Ürün kodları elle girildiği için veri doprulama ile listelemek pek kullanışlı olmayacaktır. Farklı ürün kodları oluşabilmektedir..

bunu nasıl yapabiliriz?

Yardımlarınız için şimdiden çok teşekkürler.
Konu hk. ulaşabileceğiniz mail adresim:

bulent_ugur@yahoo.com

Saygılarımla

 

[bugur]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D]) Is Nothing Then Exit Sub
Dim p As Object, t As Double, l As Double, w As Double, h As Double

ResimDosya = "C:\urunler" & "\" & Target.Value & ".jpg"

If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)

With Cells(Target.Row, Target.Column + 1)
t = .Top + 3
l = .Left + 3
w = .Width - 3
h = .Height - 3
End With

With p
.Top = t
.Left = l
.Width = w
.Height = h
End With

Set p = Nothing

End Sub


bu şekilde oldu. yaptım...

 

[bugur]

yalnız şöyle bir sorunum var:

ürün kodunu girdiğimde resim otomatik geliyor. o satırda başka ürün kodu girersem önceki gelmiş olan resmin üstüne resim geliyor. kodun Önce gelmiş olan resmi silip sonrasında yeni resmi getirmesi için ne yapabiliriz?

teşekkürler..

 

[Necdet]

Merhaba,

Kodları aşağıdaki gibi dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, [D:D]) Is Nothing Then Exit Sub
    Dim p As Object, t As Double, l As Double, w As Double, h As Double
    
   [B][COLOR=red] ActiveSheet.DrawingObjects.Delete
[/COLOR][/B]    
    ResimDosya = "C:\urunler" & "\" & Target.Value & ".jpg"
    
    If Dir(ResimDosya) = "" Then Exit Sub
    Set p = ActiveSheet.Pictures.Insert(ResimDosya)
    
    With Target.Offset(0, 1)
        t = .Top + 3
        l = .Left + 3
        w = .Width - 3
        h = .Height - 3
    End With
    
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    
    Set p = Nothing
End Sub

 

[bugur]

Necdet Bey teşekkür ederim. kodlarınız ile oldu.

Saygılarımla

 

[bugur]

oldu demiştim ama tam olmamış. şöyle ki, resim gelirken önceki resmi silip yeni resmi ekliyor ama diğer satırlardaki resimler komple siliniyor. bunu nasıl çözebiliriz? Fikri olan var mıdır?

Teşekkürler..

 

[tahsinanarat]

Keşke bir örnek dosya eklemiş olsaydınız.

 

[enginozen]

klasörden resim ekleme

Merhabalar elimde ekteki gibi bir dosya mevcut.

önceden doğru çalışıyordu ancak şimdi resimler ilk hücrede üst üste çıkıyor.

düzeltmek mümkün müdür, versiyon farkından mı kaynaklanıyor?

Teşekkürler
Engin Özen
enginozen@gmail.com