Klasörden Resim Çağırma Hk.

EKREM1661 · 7 Temmuz 2011

Değerli Arkadaşlar..!

Aşağıda ThisWorkbook sayfasına yazılı kod ile, içinde resim olan klasörden resim çağırıyorum.

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
Syf = ActiveSheet.Name
sat = ActiveCell.Row
Sheets(Syf).Image1.Picture = LoadPicture(ActiveWorkbook.Path & "\" & Syf & "\" & Cells(sat, 2).Value & ".jpg")
End Sub

Burada; eğer excel sayfasında B sütununda seçilen isimle, klasördeki aynı isimle eşleşen resim var ise; resim image1 nesnesinde görüntüye geliyor.

Bundan sonra yapmak istediğim şu.. Eğer aynı isimle eşleşen resim yoksa, "Resim Yok" adlı jpg resmini (dosyasını) görüntüye getirsin..

Bu mantığı, yukarıdaki koda ilave yapabillirsek çok memnun olurum.. Gerekirse örnek dosya eklerim.

Huseyinkis · 7 Temmuz 2011

Daha onceden karşılaşan cozume bulunan cevap sanırım işinize yarar ekteki linki incelermisiniz.

http://www.excel.web.tr/f48/resim-ekleme-makro-hatasy-t93897.html

EKREM1661 · 7 Temmuz 2011

Hüseyin bey..! ben yinede örnek dosyayı ekleyeyim.

Huseyinkis · 8 Temmuz 2011

EKREM1661' Alıntı:
Hüseyin bey..! ben yinede örnek dosyayı ekleyeyim.

Ekteki Kodları Denermisiniz.

Kod:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
sayf = ActiveSheet.Name
sat = ActiveCell.Row

spicture = (ActiveWorkbook.Path & "\" & sayf & "\" & Cells(sat, 2).Value & ".jpg")
If Dir(spicture) = "" Then spicture = (ActiveWorkbook.Path & "\" & sayf & "\" & "resimyok.GIF")

Sheets(sayf).Image1.Picture = LoadPicture(spicture)
userform4.Image1.Picture = LoadPicture(spicture)

userform4.Caption = Cells(sat, 2).Value
userform4.Label1.Caption = Cells(sat, 2).Value

End Sub

EKREM1661 · 8 Temmuz 2011

Sayın Huseyinkis çok makbule geçti ve çok teşekkür ederim..

aasaa · 26 Haziran 2012

arkadaşlar bu kod nereye yazılacak bunun hakkında da biraz bilgi verseniz

koboy · 28 Eylül 2015

sabit yol belirtme

Merhaba bu kodda sayfa ve klasör ismi aynı ise resimler geliyor.Benim 3 adet excel sayfam var bunların resimleri açıklamalar aynı ançak sayfa isimleri farklı olduğu için resimler gelmiyor sayfa isminde klasör yapınca da yer çok kaplıyor ortak bir klasör yolu nasıl yapalirim

Huseyinkis' Alıntı:

Ekteki Kodları Denermisiniz.

Kod:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
sayf = ActiveSheet.Name
sat = ActiveCell.Row

spicture = (ActiveWorkbook.Path & "\" & sayf & "\" & Cells(sat, 2).Value & ".jpg")
If Dir(spicture) = "" Then spicture = (ActiveWorkbook.Path & "\" & sayf & "\" & "resimyok.GIF")

Sheets(sayf).Image1.Picture = LoadPicture(spicture)
userform4.Image1.Picture = LoadPicture(spicture)

userform4.Caption = Cells(sat, 2).Value
userform4.Label1.Caption = Cells(sat, 2).Value

End Sub

Orion1 · 28 Eylül 2015

koboy' Alıntı:
Merhaba bu kodda sayfa ve klasör ismi aynı ise resimler geliyor.Benim 3 adet excel sayfam var bunların resimleri açıklamalar aynı ançak sayfa isimleri farklı olduğu için resimler gelmiyor sayfa isminde klasör yapınca da yer çok kaplıyor ortak bir klasör yolu nasıl yapalirim

Örnek dosya ekleyiniz.

koboy · 1 Ekim 2015

bilgi

Merhabalar dosya ekleyemiyorum

dosya link ekleyebildim : http://s6.dosya.tc/server3/rgx2xn/dosya.rar.html

Orion1' Alıntı:
Örnek dosya ekleyiniz.

Orion1 · 1 Ekim 2015

koboy' Alıntı:
Merhaba bu kodda sayfa ve klasör ismi aynı ise resimler geliyor.Benim 3 adet excel sayfam var bunların resimleri açıklamalar aynı ançak sayfa isimleri farklı olduğu için resimler gelmiyor sayfa isminde klasör yapınca da yer çok kaplıyor ortak bir klasör yolu nasıl yapalirim

Mesela hangi resim gelmiyor?

koboy · 2 Ekim 2015

Yardım

Orion1' Alıntı:
Mesela hangi resim gelmiyor?

Merhaba,

Benim resimlerimin olduğu klasör adı katalog- excel sayfamın ismide katalog - excel katalog sayfadaki tüm resimler geliyor ançak excel aile sayfadaki hiçbir resim gelmiyor kodlar filan iki sayfada aynı makro sorgununda ortak bir resim klasörü yolu versem excel sayfa ismin ne olursa olsun bulur çünkü exceldeki isimlerle resimdeki isimler aynı hep

koboy · 26 Ekim 2015

merhabalar yardımcı olabilecek misiniz

denese · 8 Nisan 2017

Merhaba,

A sütunundaki numaralandırılmış hücre isimlerini klasörde arayıp, aynı isimdeki resim dosyasını C sütunundaki hücrelere yerleştirecek kodu örnek dosya üzerinde uyarlamaya çalıştım.

Kod:

Sub ExcDep()
    Application.ScreenUpdating = False
    resimyolu = ThisWorkbook.Path & "\Fotoğraflar\"
    Form.OLEObjects.Delete
    sat = [a100000].End(3).Row
    For s = 10 To sat
        DoEvents
        If Dir(resimyolu & Cells(s, "a") & ".jpeg") <> "" Then uzanti = ".jpeg"
        If Dir(resimyolu & Cells(s, "a") & ".jpg") <> "" Then uzanti = ".jpg"
        If uzanti <> "" Then
            Set p = ActiveSheet.OLEObjects.Add( _
                        ClassType:="Forms.Image.1", _
                        Left:=Cells(s, "c").Left, _
                        Top:=Cells(s, "c").Top, _
                        Width:=Cells(s, "c").Width, _
                        Height:=Cells(s, "c").RowHeight)
            Set r = p.Object
            r.PictureSizeMode = fmPictureSizeModeStretch
            r.Picture = LoadPicture(resimyolu & Cells(s, "a") & uzanti)
        End If
        uzanti = ""
    Next
    Application.ScreenUpdating = True
End Sub

Kod orjinal dosyada çalışıyor ancak uyarladığım bu dosyada hata veriyor.

Yardımcı olabilir misiniz.

http://s9.dosya.tc/server2/gmgaic/resim_getir.rar.html

Asri · 9 Nisan 2017

denese' Alıntı:
Form.OLEObjects.Delete

Buradaki kodu aşağıdaki şekilde değiştirin.

Kod:

  ActiveSheet.OLEObjects.Delete

denese · 9 Nisan 2017

Çok teşekkürler.

Resimler hücreye yerleşince fark ettim; resimleri hücre içerisine yerleştiriyor ancak biraz kırparak yerleştiriyor. Resmi, çözünürlüğü ne olursa olsun hücre içine tam olarak yerleştirebilmemiz mümkün mü?

-------------

Sayın Asri, dosya üzerinde ikinci denemede sorun çözüldü, tekrar teşekkür ederim.

denese · 9 Nisan 2017

Sayın Asri;

"Tüm Resimleri Sil" butonu eklemek istersek, bu konuda da yardımcı olabilir misiniz.

--------------

Forumda araştırmadan sormuş bulundum, kusura bakmayın.

Kod:

Sub resim_sil()
Dim resimler As Integer
resimler = ActiveSheet.Pictures.Count
For i = 1 To resimler
ActiveSheet.Pictures(1).Delete
Next
End Sub

bu kodla sonuca ulaştım.

çok teşekkürler.

denese · 9 Nisan 2017

Merhaba Sayın Asri,

Bu kodu farklı bir çalışma kitabında uyguladığımda, bu sefer "runtime error 53 file not found" hatası oluşuyor, fakat sonrasında resimler geliyor.

Çalışma sayfasında sadece hücrelere getirilen resimlerim silinmesi konusunda da desteğinize ihtiyacım var.

Her iki konuyu da forumda araştırdım fakat işin içinden çıkamadım.

http://s9.dosya.tc/server2/otrdq7/resim_getir.rar.html

Asri · 9 Nisan 2017

denese' Alıntı:
..Bu kodu farklı bir çalışma kitabında uyguladığımda, bu sefer "runtime error 53 file not found" hatası oluşuyor, fakat sonrasında resimler geliyor.

Çalışma sayfasında sadece hücrelere getirilen resimlerim silinmesi konusunda da desteğinize ihtiyacım var...

Her iki sorun için de kodları aşağıdaki şekilde değiştirerek deneyiniz.

Kod:

Sub resimleri_getir()
    Application.ScreenUpdating = False
    resimyolu = ThisWorkbook.Path & "\Resimler\"
    ActiveSheet.OLEObjects.Delete
    sat = Cells(Rows.Count, "A").End(3).Row
    For s = 10 To sat
        DoEvents
        varmi = False
        If dosyavarmi(resimyolu & Cells(s, "a") & ".jpeg") Then
           varmi = True
           dosyaadi = resimyolu & Cells(s, "a") & ".jpeg"
        End If
        
        If dosyavarmi(resimyolu & Cells(s, "a") & ".jpg") Then
           varmi = True
           dosyaadi = resimyolu & Cells(s, "a") & ".jpg"
        End If
        
        If varmi Then
            Set p = ActiveSheet.OLEObjects.Add( _
                        ClassType:="Forms.Image.1", _
                        Left:=Cells(s, "c").Left, _
                        Top:=Cells(s, "c").Top, _
                        Width:=Cells(s, "c").Width, _
                        Height:=Cells(s, "c").RowHeight)
            Set r = p.Object
            r.PictureSizeMode = fmPictureSizeModeStretch
            r.Picture = LoadPicture(dosyaadi)
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Sub resim_sil()
  Dim sShape As Shape
  Dim MyRange As Range
  sonsatir = Cells(Rows.Count, "A").End(3).Row
  Set MyRange = Range("C1:C" & sonsatir)
  On Error Resume Next
  For Each sShape In ActiveSheet.Shapes
    If Not Intersect(Range(sShape.TopLeftCell.Address), MyRange) Is Nothing Then
       sShape.Delete
    End If
  Next
End Sub

Function dosyavarmi(dosya)
  Dim ds, a
  Set ds = CreateObject("Scripting.FileSystemObject")
  a = ds.FileExists(dosya)
  If a = True Then
    dosyavarmi = True
  Else
    dosyavarmi = False
  End If
End Function

denese · 9 Nisan 2017

Merhaba Sayın Asri,

Yardımlarınız için sonsuz teşekkürler,

İyi çalışmalar dilerim.

snn38 · 5 Mayıs 2017

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E2]) Is Nothing Then Exit Sub
On Error GoTo çıkış
ActiveSheet.DrawingObjects.Delete
Dim Resimyolu As Variant
Dim resim As Object
Resimyolu = ActiveWorkbook.Path & "\" & Range("E2") & ".jpg"
Set resim = ActiveSheet.Pictures.Insert(Resimyolu)
With Range("G10")
resim.Top = .Top
resim.Left = .Left
resim.Height = .Height
resim.Width = .Width
End With

çıkış:

End Sub

arkadaşlar bende bu kodu kullanıyorum ama sayfadaki tüm resimleri siliyor
sadece silinen dosyaları silmesi için kodda nereyi değiştirmeliyim
herkesi iyi geceler

Klasörden Resim Çağırma Hk.

EKREM1661

Huseyinkis

EKREM1661

Ekli dosyalar

Huseyinkis

EKREM1661

aasaa

koboy

Orion1

Uzman

koboy

Orion1

Uzman

koboy

koboy

denese

Ekli dosyalar

Asri

denese

denese

denese

Ekli dosyalar

Asri

denese

snn38