Klasörden Resim Çağırma Kodu Sorunu

[RAUVAS]

Arkadaşlar Merhaba,

Şirketin Proforma Invoicesi için excelde Geliştirici Modundan "Klasörden Resim Çağırma" kodu eklemesi yaptım. Kod başarıyla çalıştı seçtiğim ürünlerin resmi istediğim gibi çıkıyor fakat aynı excel içerisinde şirketin logosu gibi bazı resimler sabit durmuyor. excelin her hangi bir noktasına tıkladığımda sabit durmasını istediğim resimler kayboluyor. Bunun için nasıl çözüm bulabilirim ?

Eklediğim kod;

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Intersect(Target, [b:b]) Is Nothing Then Exit Sub

'hata kontrolü
On Error GoTo çıkış
' Resimleri Sil

ActiveSheet.DrawingObjects.Delete
'Resim yolunun bulunması

Dim ResimYolu As Variant
Dim Resim As Object

For satır = 14 To 22

ResimYolu = ActiveWorkbook.Path & "\" & Range("b" & satır) & ".jpg"

' Resmi oluştur
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'Resmi Boyutlandır

With Range("c" & satır)
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With

Next satır

çıkış:
End Sub

 

[RAUVAS]

Yardımcı olursanız sevinirim. Bu kod çalışırken şirketin logosu sabit kalsın istiyorum. İlgili dosyanın her hangi bir yerine tıklayınca sabit durmasını istediğim resimler gidiyor. Sadece kodda klasörden çağırmasını istediğim resimler yükleniyor.

 

[halit3]

örnek dosyanız olmadığından bir yorum yapmak zor
ama bu bölüm sayfadaki bütün resimleri siler,
ActiveSheet.DrawingObjects.Delete

 

[PLİNT]

Sn Halit3 'ün belirttiği kodlarınızın içindeki

ActiveSheet.DrawingObjects.Delete
'Resim yolunun bulunması

yerine

For Each x In ActiveSheet.Shapes
If Not Intersect(x.TopLeftCell, Range("C1:C100")) Is Nothing Then
x.Delete
End If
Next x

"Range("C1:C100")" satır aralığını ayarlayın

 

[RAUVAS]

rkadaşlar öncelikle cevaplar için teşekkür ederim. Dosya ekleyi bulamadım ilgili makro dosyasını link olarak ekledim http://www.stopgrup.om/example.xlsm

Resimle tarif etmek gerekirse C14 den C20 ye kadar seçilebilir resimler tanımladım. Oralarda yukarıda vermiş olduğum kodlarla resimler sorunsuz çıkıyor. Fakat en yukarda solda şirket logomuz var. Sabit olarak durmuyor. Her hangi bir yere tıkladığımda kayboluyor. İlgili dosyayıda ekledim. Yardımcı olursanız sevinirim.

 

[PLİNT]

Merhaba
Ek dosyayı deneyiniz "B14:B20" aralığında veri (resim adı) seçildiğinde "C" hücresine resim getirecektir, "B" hücresi boşaltıldığında karşısındaki resim
silinecek
https://dosyaup.com/d/BRWVWFG

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B14:B20")) Is Nothing Then Exit Sub
Dim ResimYolu As Variant
Dim Resim As Object
'hata kontrolü
'On Error GoTo çıkış
If Target.Value = "" Then
For Each x In ActiveSheet.Shapes
If Val(x.Top) = Val(Range("C" & Target.Row).Top) Then
x.Delete
End If
Next x
Else
ResimYolu = ActiveWorkbook.Path & "\" & Target.Value & ".jpg"
If Dir(ResimYolu) <> "" Then
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
With Range("c" & Target.Row)
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
Resim.Top = .Top
End With
Else
MsgBox "Resim Bulunamadı"
End If: End If
çıkış:
End Sub

 

[RAUVAS]

Cevaplarınız çok yardımcı oldu teşekkür ederim. Bir sorum daha olacaktı resim çağırma kodunda resimler ilgili excel ile aynı dizinde olunca görünüyor. Aynı klasör içinde(index kısmı) resimlerin /resimler klasörü içinden çağrılmasını nasıl sağlayabilirim ?

 

[PLİNT]

Merhaba
Kodların içinde; "Resimyolu" tanımını değiştirmeniz yeterli olacaktır

ResimYolu = ActiveWorkbook.Path & "\resimler\" & Target.Value & ".jpg"

 

[RAUVAS]

Merhaba
Kodların içinde; "Resimyolu" tanımını değiştirmeniz yeterli olacaktır

ResimYolu = ActiveWorkbook.Path & "\resimler\" & Target.Value & ".jpg"

Bu kodu kullandığımda resimde ki hatayı alıyorum nasıl çözebilirim ? bir klasör içerisinde ilgili excel var onun bulunduğu klasörde /resimler diye klasör açtım. Oradan resimleri çekmedi.

 

[RAUVAS]

Şimdi halloldu teşekkür ederim.

 

[PLİNT]

Kolay gelsin.

 

[mühendis5858]

Selam Arkadaşlar benim sorunum şu
Excelde bilirkişi raporu hazırladığım bir program yazdım. Vba kullanmadan yazdım. Bu programda rapor sayfasında p7 hücresine hangi dosya numarasini girsem b82:k82 arasına uydu isimli klasörden p7 deki dosya numarası kaç ise o numara ile aynı numaralı resmi getirsin. yine P7 ye girdiğim dosya numarası kaç ise B281:k281 arasına ise bu programında içinde bulunduğu Resimli isimli klasördeki keşif fotoğrafını getirsin şimdiden sağolun tesekkuler kilci@enginner.com adresine atabilirseniz kodu çok iyi olur dostlar.