• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Klasörden Resim Çağırma Hk.

E

EKREM1661

Katılım
10 Kasım 2006
Mesajlar
1,288
Excel Vers. ve Dili
Excel-2016
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.
 
EKREM1661' Alıntı:
Hüseyin bey..! ben yinede örnek dosyayı ekleyeyim.
Genişletmek için tıkla ...


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
 
Sayın Huseyinkis çok makbule geçti ve çok teşekkür ederim..
 
arkadaşlar bu kod nereye yazılacak bunun hakkında da biraz bilgi verseniz
 
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
Genişletmek için tıkla ...
 
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
Genişletmek için tıkla ...

Örnek dosya ekleyiniz.:cool:
 
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
Genişletmek için tıkla ...

Mesela hangi resim gelmiyor?
 
Yardım

Orion1' Alıntı:
Mesela hangi resim gelmiyor?
Genişletmek için tıkla ...
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
 
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
 

Ekli dosyalar

Ç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.
 
Son düzenleme:
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.
 
Son düzenleme:
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
 

Ekli dosyalar

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...
Genişletmek için tıkla ...

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
 
Merhaba Sayın Asri,

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

İyi çalışmalar dilerim.
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst