Klasörden Resim Çağırma Hk.

Asri · 5 Mayıs 2017

İki yöntem ile yapılabilir.

1- Tüm resimleri silersiniz. İlgili yerlere klasördeki resimleri yüklersiniz.
Bu şekilde sadece var olan resimler yüklenmiş olur.
2- İlk yükleme yaparken resimleri yüklerken resim isimlerini dosya isimleri ile aynı yaparsınız. Daha sonra resim isimleri klasörde aranır, yok ise excel den silinir.

akcayonline · 14 Mart 2018

Merhaba, arkadaşlar hücreye klasörden resim çağırma ile ilgili, özet tablomdaki E1 hücresindeki değere göre G1:H6 birleştirilmiş hücresine resim gelmesini istiyorum. Bu konuda aşağıdaki internet adresindeki kod bilgisi ve ekli dosya çok yardımcı oldu fakat bir türlü resimi ilgili dosyadaki gibi sabit olarak G1:H6 birleştirilmiş hücreye sabitlemeyi başaramadım. Kendi hazırladığım dosyada resim şu an mouse ı nereye tıklarsam oraya geliyor ve boyutlandırılmadan geliyor. Bu kodda nereyi ne şekilde değiştirmem lazım , destek olabilir misiniz.

http://www.yazilimmutfagi.com/11438/ms-office/excel/excelde-klasorden-dinamik-resim-cagirma-ekleme-ve-gosterme-ornek.aspx

Mevcut kod ;

'resmi oluşturuyoruz.
Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
'Resmi boyutlandırıyoruz
With Range("g1:h6" & i)
*****Resim.Top = .Top
*****Resim.Left = .Left
*****Resim.Height = .Height
*****Resim.Width = .Width
End With

askm · 14 Mart 2018

İlgili linkdeki kodları kullanarak aşağıdaki şekilde yapabilirsiniz. Döngü kurmanıza gerek yok.

Kod:

Public Function DosyaVarmi(dosyayolu As String) As Boolean
    On Error GoTo Çikis
    If Not Dir(dosyayolu, vbDirectory) = vbNullString Then DosyaVarmi = True
     
Çikis:
    On Error GoTo 0
End Function
 
'worksheette bir degisiklik oldugunda bu kisim çalisiyor
Private Sub Worksheet_Change(ByVal Target As Range)
 
'degisiklik b sutunundami olmus diye kontrol et, degilse direk olarak fonksiyondan çik
If Intersect(Target, [E1]) Is Nothing Then Exit Sub
 
'herhangi bir hata olusursa Çikis labelina git
On Error GoTo Çikis:
 
' ilk olarak yüklü olan Resimleri silelim
ActiveSheet.DrawingObjects.Delete
 
Dim ResimDosyaYolu As String
Dim Resim As Object
 
'b deki 5 ile 12 arasindaki satirlari kontrol edip resim atamasi yapiyoruz, siz burayi isteginize göre artirabilirsiniz
'For i = 5 To 12
    'aktif sayfanin path bilgisini alip, seçilen ürün idyi sonuna ekliyoruz ve dosyayi aliyoruz
    ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("E" & 1) & ".jpg"
 
    'dosya yok ise hataya düsmemek için asagidaki kontrolü yapiyoruz.
    If DosyaVarmi(ResimDosyaYolu) Then
         ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("E" & 1) & ".jpg"
   Else
         ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
   End If
         
    'resmi olusturuyoruz.
     Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
     'Resmi boyutlandiriyoruz
     With Range("g1:h6")
     Resim.ShapeRange.LockAspectRatio = msoFalse
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With
 
'Next i
Çikis:
End Sub

akcayonline · 14 Mart 2018

askm' Alıntı:

İlgili linkdeki kodları kullanarak aşağıdaki şekilde yapabilirsiniz. Döngü kurmanıza gerek yok.

Kod:

Public Function DosyaVarmi(dosyayolu As String) As Boolean
    On Error GoTo Çikis
    If Not Dir(dosyayolu, vbDirectory) = vbNullString Then DosyaVarmi = True
     
Çikis:
    On Error GoTo 0
End Function
 
'worksheette bir degisiklik oldugunda bu kisim çalisiyor
Private Sub Worksheet_Change(ByVal Target As Range)
 
'degisiklik b sutunundami olmus diye kontrol et, degilse direk olarak fonksiyondan çik
If Intersect(Target, [E1]) Is Nothing Then Exit Sub
 
'herhangi bir hata olusursa Çikis labelina git
On Error GoTo Çikis:
 
' ilk olarak yüklü olan Resimleri silelim
ActiveSheet.DrawingObjects.Delete
 
Dim ResimDosyaYolu As String
Dim Resim As Object
 
'b deki 5 ile 12 arasindaki satirlari kontrol edip resim atamasi yapiyoruz, siz burayi isteginize göre artirabilirsiniz
'For i = 5 To 12
    'aktif sayfanin path bilgisini alip, seçilen ürün idyi sonuna ekliyoruz ve dosyayi aliyoruz
    ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("E" & 1) & ".jpg"
 
    'dosya yok ise hataya düsmemek için asagidaki kontrolü yapiyoruz.
    If DosyaVarmi(ResimDosyaYolu) Then
         ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("E" & 1) & ".jpg"
   Else
         ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
   End If
         
    'resmi olusturuyoruz.
     Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
     'Resmi boyutlandiriyoruz
     With Range("g1:h6")
     Resim.ShapeRange.LockAspectRatio = msoFalse
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With
 
'Next i
Çikis:
End Sub

Merhaba sayın "askm", öncelikle yardımlarınız için çok teşekkür ederim. Problem çözüldü. Konuyla ilgili bir soru daha sormak istiyorum. Normalde ilgili excel dosyasını deneme amaçlı resim ile aynı klasörde tutarak deneme yapıyordum. Bu şekilde sizinde katkılarınızla problem çözülmüştü. Fakat şimdi dosyayı firmanın ortak klasörlerine taşıdım ve resimler için de ek bir klasör oluşturdum ve koddaki kısayol alanına ilgili yolu yazdım ama bu sefer resimler gelmedi. Excel dosyasının kısayolunu ve resimlerin kısayolunu aşağıda paylaşıyorum, desteğinizi rica ederim. Bu durumda makrodaki dosya yolu kısımlarını nasıl düzenlemem lazım?

Not: Ortak kullanıma açık firma dosyalarına firmadayken de dahil olmak üzere wireless ağ bağlantısı üzerinden bağlanıyoruz. Belki hata sebebi bu olabilir diye not düşmek istedim.

Dosya kısayolu : \\xxxxx\depo\Planlama\Günlük_Planlama\2018\Mart
Resim kısayolu : \\xxxxx\depo\Planlama\Desen_resimler

askm · 14 Mart 2018

Öncelikle kodun başına
Dim Resim_yolu
Resim_yolu : "\\xxxxx\depo\Planlama\Desen_resimler"
ekleyin sonra
ActiveWorkbook.Path gördüğünüz yerlere Resim_yolu yazarak deneyin.

akcayonline · 14 Mart 2018

Bu hayatımda makroyla ilk tanışmam olduğu için uğraştım ama yapamadım. Ekte ekran görüntüsünü gönderiyorum, teşekkür ederim.

akcayonline · 14 Mart 2018

sanırım ekran görüntüsü görnümüyor, linki aşağıya yazıyorum, umarım bu şekilde görünür.

http://s7.dosya.tc/server4/uddgb0/Ekran_Alintisi.JPG.html

akcayonline · 14 Mart 2018

Tamam çözdüm, askm çok teşekkür ederim, sizin sayenizde oldu.

askm · 14 Mart 2018

Rica ederim. Kolay gelsin.

vein03051976 · 14 Mart 2018

Merhabalar

Örnek dosya ektedir. kodda aşağıdaki gibidir.

"D" sütünundaki model kodlarına göre "AS" sütununa resim eklemek istiyorum. Problemi bulamadım. Yardımlarınız için teşekkürler

Private Sub Worksheet(ByVal Target As Range)

If Intersect(Target, [d:d]) 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 = 6 To 100

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

Set resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

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

Next satır

Çıkış:

End Sub

askm · 14 Mart 2018

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [d:d]) 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 = 6 To 100

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

Set resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

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

Next satır

Çıkış:

End Sub

vein03051976 · 16 Mart 2018

askm' Alıntı:

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [d:d]) 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 = 6 To 100

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

Set resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

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

Next satır

Çıkış:

End Sub

Merhaba

Sizin kodu ekledim ama sadece 1. satıra getiriyor.

Bu raporu başka bir programdan excele atıyorum kodların yanına tırnak işareti atıyor

Bu yüzden AR sütununa göre arama yapsın dedim ama gene olmadı.

HÜcreye tam olarak resmide sığdırmıyor

askm · 16 Mart 2018

Change olayı ile resim çağırıp döngü neden kullandığınızı anlamadım.Eğer döngü kullanacaksanız butona atamanız gerekir.
Normalde kodlar resim ekliyor ama eklene resimler tekrar döngü içerisinde siliniyordu.
Aşağıdaki şekilde deneyin.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [AR:AR]) Is Nothing Then Exit Sub
Dim Resim As Picture, Alan As Range
' hata kontrolü
On Error GoTo Çıkış

'resimleri Sil
Set Alan = Range("AS" & Target.Row)
 For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
Next
    
'ActiveSheet.DrawingObjects.Delete

'resim yolunun bulunması

Dim ResimYolu As Variant


'For satır = 6 To 100

ResimYolu = ActiveWorkbook.Path & "\" & Range("AR" & Target.Row) & ".jpg"

Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

With Range("AS" & Target.Row)
Resim.ShapeRange.LockAspectRatio = False
Resim.Height = .Height
Resim.Width = .Width
Resim.Top = .Top
Resim.Left = .Left
End With

'Next satır

Çıkış:

End Sub

vein03051976 · 16 Mart 2018

askm' Alıntı:

Change olayı ile resim çağırıp döngü neden kullandığınızı anlamadım.Eğer döngü kullanacaksanız butona atamanız gerekir.
Normalde kodlar resim ekliyor ama eklene resimler tekrar döngü içerisinde siliniyordu.
Aşağıdaki şekilde deneyin.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [AR:AR]) Is Nothing Then Exit Sub
Dim Resim As Picture, Alan As Range
' hata kontrolü
On Error GoTo Çıkış

'resimleri Sil
Set Alan = Range("AS" & Target.Row)
 For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
Next
    
'ActiveSheet.DrawingObjects.Delete

'resim yolunun bulunması

Dim ResimYolu As Variant


'For satır = 6 To 100

ResimYolu = ActiveWorkbook.Path & "\" & Range("AR" & Target.Row) & ".jpg"

Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

With Range("AS" & Target.Row)
Resim.ShapeRange.LockAspectRatio = False
Resim.Height = .Height
Resim.Width = .Width
Resim.Top = .Top
Resim.Left = .Left
End With

'Next satır

Çıkış:

End Sub

Merhaba

Aşağıdaki linkten aldım bu kodu

https://www.youtube.com/watch?v=KZwcN8DhaT0

Şimdi resim geliyor ama yeni bir kod yazdığımda resim silinmiyor

askm · 16 Mart 2018

Aktif satırdaki AS sütunundaki resimleri siliyor sorun gözükmüyor.

vein03051976 · 16 Mart 2018

askm' Alıntı:
Aktif satırdaki AS sütunundaki resimleri siliyor sorun gözükmüyor.

Şöyleki

Ben bu raporu excel atıp bu tabloya yapıştıracağım bu yüzden "D" sütunundaki kodlar değişecek

Şimdi manuel 5-6-7-8 yazdım "AR" sutünundaki resimler hata verdi.Yeni resimleri "AS" sütununa attı

Tablo ekteki gibi oldu

askm · 16 Mart 2018

Bir önceki kodlar AR sütununa göre işlem yapıyordu. Yani resim adları AR sütununda idi. Şimdi D sütununa almışsınız. R sütununa herhangi bir müdahele yok kodların içerisinde. Ne resimlerini siliyor ne de resim ekliyor. Eklediğiniz resimdeki hatalar Daha önceden yüklediğiniz dosyada resimlerin olmadığını yani artık resimlerin var olan yerinde olmadığını bildiriyor.

vein03051976 · 19 Mart 2018

askm' Alıntı:
Bir önceki kodlar AR sütununa göre işlem yapıyordu. Yani resim adları AR sütununda idi. Şimdi D sütununa almışsınız. R sütununa herhangi bir müdahele yok kodların içerisinde. Ne resimlerini siliyor ne de resim ekliyor. Eklediğiniz resimdeki hatalar Daha önceden yüklediğiniz dosyada resimlerin olmadığını yani artık resimlerin var olan yerinde olmadığını bildiriyor.

Sayın askm

İlginize çok teşekkürler

Kodu aşağıdaki şekilde düzelttim. AR sütununa artık resimler gelmiyor. Sadece "AS" sütununa geliyor

Sadece Raporu yapıştırdığım da "D" sütununda F2+Enter yapmam gerekiyor. Yoksa resimler gelmiyor.

Tekrar teşekkürler

Düzeltilmiş Kod

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [D

]) Is Nothing Then Exit Sub
Dim Resim As Picture, Alan As Range
' hata kontrolü
On Error GoTo Çıkış

'resimleri Sil
Set Alan = Range("AR" & Target.Row)
For Each Resim In ActiveSheet.Pictures
If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
Resim.Delete
End If
Next

'ActiveSheet.DrawingObjects.Delete

'resim yolunun bulunması

Dim ResimYolu As Variant

'For satır = 6 To 100

ResimYolu = ActiveWorkbook.Path & "\" & Range("D" & Target.Row) & ".jpg"

Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'resmi boyutlandır

With Range("AS" & Target.Row)
Resim.ShapeRange.LockAspectRatio = False
Resim.Height = .Height
Resim.Width = .Width
Resim.Top = .Top
Resim.Left = .Left
End With

'Next satır

Çıkış:

End Sub

pınarh · 19 Mart 2018

merhaba benzer bir sorun yaşıyorum hata kontrolünü değiştirmem gerekiyor aranan isinde resim yoksa hatayı yok sayıp sıradakine devam etmesini yada belirlediğim bir resmi koyup sıradakine devam etmesi istiyorum yardımcı olursanız çok sevinirim

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [c:c]) 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 = 3 To 1103 Step 11

Resimyolu = ActiveWorkbook.Path & "\" & Range("c" & satır) & ".jpg"

'resim oluştur
Set Resim = ActiveSheet.Pictures.Insert(Resimyolu)

'Resimi Boyutlandır

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

Next satır

çıkış:
End Sub

akcayonline · 17 Nisan 2018

askm' Alıntı:
Rica ederim. Kolay gelsin.

Merhaba, bana daha önce yardım ettiğiniz bu konuda sorum olacaktı.
Şimdi resim çağırdığım sayfaya adım ile makro kaydedip buton ataması yapmak istiyorum, aslında yapıyorum da ama filtrelerdeki değeri değiştirince buton kayboluyor. özelliklerden otomatik taşıma ve boyutlandırmayı kaldırdığım halde yine kayboluyor. Forumda bir arkadaş daha önceki destek verdiğiniz makro kodundaki bir satır sebebiyle butonun da silindiğini söyledi (ActiveSheet.DrawingObjects.Delete). Bahsettiği satır sanırım mevcut resimi silmek için kullanılan satır. Sizden ricam silme işlemini 9. satırdan itibaren başlamasını sağlayabiliyor muyuz ? Ben ilk 8 satıra makro butonları koyacağım. Resmi de N9:O28 arasına konumlandırdım. Destekleriniz için teşekkürler.

Klasörden Resim Çağırma Hk.

Asri

akcayonline

askm

Destek Ekibi

akcayonline

askm

Destek Ekibi

akcayonline

Ekli dosyalar

akcayonline

akcayonline

askm

Destek Ekibi

vein03051976

Ekli dosyalar

askm

Destek Ekibi

vein03051976

Ekli dosyalar

askm

Destek Ekibi

vein03051976

askm

Destek Ekibi

vein03051976

Ekli dosyalar

askm

Destek Ekibi

vein03051976

pınarh

akcayonline