Açılan Kutudan, Seçilen İsme Ait Resmin Gelmesi

1Al2Ver · 13 Eylül 2008

Merhabalar,

Sayfa1'de B1(per.ismi), Sayfa2'de O1:O14 hücresindeki verilere(pers.resmi) göre;

Sayfa2'de O1:O14 hücresinde yolu belirlenen resimlerin Sayfa1 A1:A13 aralığına gelmesi arzulanmaktadır.

Sayfa2'de bir kod var, doğal olarak bu kod ile istenilen sonucu alamadım,

Bu işlem için gereken kodu rica ediyorum,teşekkür ederim.

Ferhat Pazarçevirdi · 13 Eylül 2008

Aşağıdaki kodları, Sayfa2(Sayfa1) yazan sheet modulüne kopylayınız.

NOT : Neden böyle bir sayfa ismi verdiğiniz anlamış değilim . Muhtemelen, Sayfa2'nin adını Sayfa1, Sayfa1'in adını da Sayfa2 olarak elle değiştirdiniz. Biraz kafa karıştırıyor bu durum

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngBul As Range
    Dim rngResimAlani As Range
    Dim oRsm As Picture
 
[COLOR=darkgreen]  'Eğer değiştirilen hücre, B1 ise[/COLOR]
    If Target.Address = Range("B1").Address Then
 
[COLOR=darkgreen]      'Resimin yerleştirileceği alanı bir değişkene ata[/COLOR]
        Set rngResimAlani = Range("A1:A13")
 
[COLOR=darkgreen]      'B1 hücresinde yazan personeli,[/COLOR]
[COLOR=darkgreen]      'Sayfa2'nin 1.sütununda ara ve[/COLOR]
[COLOR=darkgreen]      'Bul veya bulma, bir değişkene ata[/COLOR]
 
        Set rngBul = Sheets("Sayfa2").Columns(1).Find(Target, Lookat:=xlWhole)
 
[COLOR=darkgreen]      'Eğer bir personel bulunduysa[/COLOR]
        If Not rngBul Is Nothing Then
 
[COLOR=darkgreen]          'Önce, Resmin yerleştirileceği alanda[/COLOR]
[COLOR=darkgreen]          'herhangi bir resim varsa, onları temizle[/COLOR]
            For Each oRsm In ActiveSheet.Pictures
                If Not Intersect(rngResimAlani, oRsm.TopLeftCell) Is Nothing Then
                    oRsm.Delete
                End If
            Next
 
[COLOR=darkgreen]          'Sayfa2'de bulunan personelin[/COLOR]
[COLOR=darkgreen]          '14 sütun sağında bulunan resim dosyası yolunu kontrol et[/COLOR]
 
[COLOR=darkgreen]            'Eğer, bu dosya halen daha bu klasörde varsa[/COLOR]
            If Len(Dir(rngBul.Offset(0, 14))) > 0 Then
 
[COLOR=darkgreen]              'Resmi, sayfaya ekle[/COLOR]
                Set oRsm = ActiveSheet.Pictures.Insert(rngBul.Offset(0, 14))
 
[COLOR=darkgreen]              'Resmi, yerleştirilecek resim alanının[/COLOR]
[COLOR=darkgreen]              'koordinatlarına ve boyutuna ayarla[/COLOR]
 
                With oRsm
                    .Left = rngResimAlani.Left
                    .Top = rngResimAlani.Top
                    oran = .Width / .Height
                    .Height = rngResimAlani.Height
                    .Width = .Height * oran
                End With
 
[COLOR=darkgreen]              'A1 hücresini her ihtimale karşı boşalt[/COLOR]
                Range("A1") = Empty
 
[COLOR=darkgreen]          'Eğer, aranılan resim bulunamaıoyrsa[/COLOR]
            Else
[COLOR=darkgreen]              'A1 hücresine bir mesaj yaz[/COLOR]
                Range("A1") = "Resim bulunamadı"
            End If
 
        End If
 
[COLOR=darkgreen]      'Hafızada oluşturduğumuz alanları boşalt[/COLOR]
        Set rngResimAlani = Nothing
        Set rngBul = Nothing
        Set oRsm = Nothing
 
    End If
 
End Sub

1Al2Ver · 13 Eylül 2008

Sayın Ferhat Pazarçevirdi, merhaba

"NOT : Neden böyle bir sayfa ismi verdiğiniz anlamış değilim . Muhtemelen, Sayfa2'nin adını Sayfa1, Sayfa1'in adını da Sayfa2 olarak elle değiştirdiniz. Biraz kafa karıştırıyor bu durum"

Benim acemiliğimden, örnek dosyadaki kodları kendimce uygulamaya çalıştım, orijinal dosyadaki gibi sayfa adı vereyim, belki becerebilirim mantığından hareketle yapmıştım, bu nedenle de size bir özür borçlandım

Çözüm için teşekkür ederim, sağolun, elinize sağlık, süper olmuş, saygılarımla.

limanC34 · 13 Eylül 2008

Sayın 1AI2Ver
Şöyle bir çözüm işinizi halleder mi?Siteden.

1Al2Ver · 13 Eylül 2008

limanC34' Alıntı:
Sayın 1AI2Ver
Şöyle bir çözüm işinizi halleder mi?Siteden.

Sayın limanC34, ilginiz için teşekkür ederim, elbette halleder, alternatif bir kaynak olarak arşivimde yerini aldı, saygılarımla.

tahsinanarat · 14 Eylül 2008

Sn. Ferhat Pazarçevirdi, yukarıdaki kodlarınızı bir türlü uygulamaya geçiremedim, bakabilirseniz sevinirim (resim dosya yollarını gösterdim)

tahsinanarat · 14 Eylül 2008

Ugraştığım dosyayı da ekleyim de

Sayfaları isimlendirdim, resim yollarını değiştirdim ancak bir türlü resmi ekranda gösteremedim. Dosyayı da ekte gönderiyorum, bakabilirseniz, sevinirim. Kodlar güzele benziyor.(resimekleme olayında)

tahsinanarat · 14 Eylül 2008

Ben dosya yolunda hata yapmışım, kodlar gayet güzel çalışıyor, elinize sağlık Sn. Ferhat Bey

Ferhat Pazarçevirdi · 14 Eylül 2008

tahsinanarat' Alıntı:
Sayfaları isimlendirdim, resim yollarını değiştirdim ancak bir türlü resmi ekranda gösteremedim. Dosyayı da ekte gönderiyorum, bakabilirseniz, sevinirim. Kodlar güzele benziyor.(resimekleme olayında)

Kodların çalışmasında, gördüğüm kadarıyla bir problem yok. Siz, "Veri" sayfasında "O" sütununda yazan resim yollarının doğru olup olmadığını kontrol ediniz. Muhtemelen belirttiğiniz yol yanlış olabilir veya bu dizin altında bu isimde bir resim olmayabilir.

1Al2Ver · 26 Eylül 2008

Ferhat Pazarçevirdi;305708' Alıntı:

Aşağıdaki kodları, Sayfa2(Sayfa1) yazan sheet modulüne kopylayınız.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngBul As Range
    Dim rngResimAlani As Range
    Dim oRsm As Picture
 
[COLOR=darkgreen]  'E&#287;er de&#287;i&#351;tirilen h&#252;cre, B1 ise[/COLOR]
    If Target.Address = Range("B1").Address Then
 
[COLOR=darkgreen]      'Resimin yerle&#351;tirilece&#287;i alan&#305; bir de&#287;i&#351;kene ata[/COLOR]
        Set rngResimAlani = Range("A1:A13")
 
[COLOR=darkgreen]      'B1 h&#252;cresinde yazan personeli,[/COLOR]
[COLOR=darkgreen]      'Sayfa2'nin 1.s&#252;tununda ara ve[/COLOR]
[COLOR=darkgreen]      'Bul veya bulma, bir de&#287;i&#351;kene ata[/COLOR]
 
        Set rngBul = Sheets("Sayfa2").Columns(1).Find(Target, Lookat:=xlWhole)
 
[COLOR=darkgreen]      'E&#287;er bir personel bulunduysa[/COLOR]
        If Not rngBul Is Nothing Then
 
[COLOR=darkgreen]          '&#214;nce, Resmin yerle&#351;tirilece&#287;i alanda[/COLOR]
[COLOR=darkgreen]          'herhangi bir resim varsa, onlar&#305; temizle[/COLOR]
            For Each oRsm In ActiveSheet.Pictures
                If Not Intersect(rngResimAlani, oRsm.TopLeftCell) Is Nothing Then
                    oRsm.Delete
                End If
            Next
 
[COLOR=darkgreen]          'Sayfa2'de bulunan personelin[/COLOR]
[COLOR=darkgreen]          '14 s&#252;tun sa&#287;&#305;nda bulunan resim dosyas&#305; yolunu kontrol et[/COLOR]
 
[COLOR=darkgreen]            'E&#287;er, bu dosya halen daha bu klas&#246;rde varsa[/COLOR]
            If Len(Dir(rngBul.Offset(0, 14))) > 0 Then
 
[COLOR=darkgreen]              'Resmi, sayfaya ekle[/COLOR]
                Set oRsm = ActiveSheet.Pictures.Insert(rngBul.Offset(0, 14))
 
[COLOR=darkgreen]              'Resmi, yerle&#351;tirilecek resim alan&#305;n&#305;n[/COLOR]
[COLOR=darkgreen]              'koordinatlar&#305;na ve boyutuna ayarla[/COLOR]
 
                With oRsm
                    .Left = rngResimAlani.Left
                    .Top = rngResimAlani.Top
                    oran = .Width / .Height
                    .Height = rngResimAlani.Height
                    .Width = .Height * oran
                End With
 
[COLOR=darkgreen]              'A1 h&#252;cresini her ihtimale kar&#351;&#305; bo&#351;alt[/COLOR]
                Range("A1") = Empty
 
[COLOR=darkgreen]          'E&#287;er, aran&#305;lan resim bulunama&#305;oyrsa[/COLOR]
            Else
[COLOR=darkgreen]              'A1 h&#252;cresine bir mesaj yaz[/COLOR]
                Range("A1") = "Resim bulunamad&#305;"
            End If
 
        End If
 
[COLOR=darkgreen]      'Haf&#305;zada olu&#351;turdu&#287;umuz alanlar&#305; bo&#351;alt[/COLOR]
        Set rngResimAlani = Nothing
        Set rngBul = Nothing
        Set oRsm = Nothing
 
    End If
 
End Sub

Sayın Ferhat Pazarçevirdi, merhabalar,

14 ncü satırın sağındaki hücre'de kayıt yok ise yani boş ise aşağıdaki kod debug hatası veriyor, bunu nasıl aşarız.

If Len(Dir(rngBul.Offset(0, 14))) > 0 Then

Olabiliyorsa; Eğer hücre boş ise "veri girişi yok" şeklinde bir mesaj almak isterim.

Teşekkür ederim.

Ferhat Pazarçevirdi · 26 Eylül 2008

Doğru, ben o kontrolü atlamışım ne yazık ki ... Kodunuzu aşağıda verdiğim şekliyle revize ediniz.

Eklenenler kırmızı renk ile gösterilmiştir.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngBul As Range
    Dim rngResimAlani As Range
    Dim oRsm As Picture
 
    If Target.Address = Range("B1").Address Then
 
        Set rngResimAlani = Range("A1:A13")
 
        Set rngBul = Sheets("Sayfa2").Columns(1).Find(Target, Lookat:=xlWhole)
 
        If Not rngBul Is Nothing Then
 
            For Each oRsm In ActiveSheet.Pictures
                If Not Intersect(rngResimAlani, oRsm.TopLeftCell) Is Nothing Then
                    oRsm.Delete
                End If
            Next
 
[COLOR=red]            If Len(rngBul.Offset(0, 14)) > 0 Then[/COLOR]
               If Len(Dir(rngBul.Offset(0, 14))) > 0 Then
    
                   Set oRsm = ActiveSheet.Pictures.Insert(rngBul.Offset(0, 14))
    
                   With oRsm
                       .Left = rngResimAlani.Left
                       .Top = rngResimAlani.Top
                       oran = .Width / .Height
                       .Height = rngResimAlani.Height
                       .Width = .Height * oran
                   End With
    
                   Range("A1") = Empty
    
               Else
                   Range("A1") = "Resim bulunamadı"
               End If
[COLOR=red]            Else[/COLOR]
[COLOR=red]               Range("A1") = "Personel resmi yok"[/COLOR]
[COLOR=red]            End If[/COLOR]
 
        End If
 
        Set rngResimAlani = Nothing
        Set rngBul = Nothing
        Set oRsm = Nothing
 
    End If
 
End Sub

1Al2Ver · 26 Eylül 2008

Sayın Ferhat Pazarçevirdi,

Teşekkür ederim, şimdi sorunsuz ve kusursuz oldu,sağolun,

Saygılarımla.

1Al2Ver · 18 Kasım 2008

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngBul As Range
    Dim rngResimAlani As Range
    Dim oRsm As Picture
 
[COLOR=darkgreen]  'Eğer değiştirilen hücre, B1 ise[/COLOR]
    If Target.Address = Range("B1").Address Then
 
[COLOR=darkgreen]      'Resimin yerleştirileceği alanı bir değişkene ata[/COLOR]
        Set rngResimAlani = Range("A1:A13")
 
[COLOR=darkgreen]      'B1 hücresinde yazan personeli,[/COLOR]
[COLOR=darkgreen]      'Sayfa2'nin 1.sütununda ara ve[/COLOR]
[COLOR=darkgreen]      'Bul veya bulma, bir değişkene ata[/COLOR]
 
        Set rngBul = Sheets("Sayfa2").Columns(1).Find(Target, Lookat:=xlWhole)
 
[COLOR=darkgreen]      'Eğer bir personel bulunduysa[/COLOR]
        If Not rngBul Is Nothing Then
 
[COLOR=darkgreen]          'Önce, Resmin yerleştirileceği alanda[/COLOR]
[COLOR=darkgreen]          'herhangi bir resim varsa, onları temizle[/COLOR]
            For Each oRsm In ActiveSheet.Pictures
                If Not Intersect(rngResimAlani, oRsm.TopLeftCell) Is Nothing Then
                    oRsm.Delete
                End If
            Next
 
[COLOR=darkgreen]          'Sayfa2'de bulunan personelin[/COLOR]
[COLOR=darkgreen]          '14 sütun sağında bulunan resim dosyası yolunu kontrol et[/COLOR]
 
[COLOR=darkgreen]            'Eğer, bu dosya halen daha bu klasörde varsa[/COLOR]
            If Len(Dir(rngBul.Offset(0, 14))) > 0 Then
 
[COLOR=darkgreen]              'Resmi, sayfaya ekle[/COLOR]
                Set oRsm = ActiveSheet.Pictures.Insert(rngBul.Offset(0, 14))
 
[COLOR=darkgreen]              'Resmi, yerleştirilecek resim alanının[/COLOR]
[COLOR=darkgreen]              'koordinatlarına ve boyutuna ayarla[/COLOR]
 
                With oRsm
                    .Left = rngResimAlani.Left
                    .Top = rngResimAlani.Top
                    oran = .Width / .Height
                    .Height = rngResimAlani.Height
                    .Width = .Height * oran
                End With
 
[COLOR=darkgreen]              'A1 hücresini her ihtimale karşı boşalt[/COLOR]
                Range("A1") = Empty
 
[COLOR=darkgreen]          'Eğer, aranılan resim bulunamaıoyrsa[/COLOR]
            Else
[COLOR=darkgreen]              'A1 hücresine bir mesaj yaz[/COLOR]
                Range("A1") = "Resim bulunamadı"
            End If
 
        End If
 
[COLOR=darkgreen]      'Hafızada oluşturduğumuz alanları boşalt[/COLOR]
        Set rngResimAlani = Nothing
        Set rngBul = Nothing
        Set oRsm = Nothing
 
    End If
 
End Sub

Merhabalar,

Kodun olduğu sayfayı, B1 hücresi dışında araçlar menüsünden korumaya aldığımda; oRsm.Delete satırında debug hatası vermekte,

Kodu iptal ettiğimde ise koruma çalışmakta,

Kod aktifken sayfayı korumak için ne yapılmalıdır ?

Teşekkür ederim.

1Al2Ver · 18 Kasım 2008

Merhabalar, 13 nolu mesajdaki kodu bozmadan sayfada hücreleri korumak mümkün olabilecek mi?

Teşekkür ederim.

Ferhat Pazarçevirdi · 18 Kasım 2008

B1 hücresi Kilitli olmamak üzere (-ki bu durumda doğrulama listeside çalışmaz) kodlarınızı şu şekilde değiştiriniz.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngBul As Range
    Dim rngResimAlani As Range
    Dim oRsm As Picture
    
 
    If Target.Address = Range("B1").Address Then
[COLOR=red]        ActiveSheet.Unprotect[/COLOR]
[COLOR=darkgreen]        '................
        '  Kodlarınız ...
        '................[/COLOR]
[COLOR=red]        ActiveSheet.Protect[/COLOR]
    End If
    
End Sub

1Al2Ver · 18 Kasım 2008

Ferhat Pazarçevirdi' Alıntı:
B1 hücresi Kilitli olmamak üzere (-ki bu durumda doğrulama listeside çalışmaz) kodlarınızı şu şekilde değiştiriniz.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range) Dim rngBul As Range Dim rngResimAlani As Range Dim oRsm As Picture If Target.Address = Range("B1").Address Then [COLOR=red] ActiveSheet.Unprotect[/COLOR] [COLOR=darkgreen] '................ ' Kodlarınız ... '................[/COLOR] [COLOR=red] ActiveSheet.Protect[/COLOR] End If End Sub

Sayın Ferhat Pazarçevirdi, merhaba

Çok teşekkür ederim, saygılarımla.

abazya · 18 Kasım 2008

Sayın 1Al2Ver,
Bitmiş halini (dosya olarak) ekleyebilirmisiniz.

ozgretmen · 18 Kasım 2008

Kodlar çok güzel...Ama örnek dosya inmiyor.Kodlardan da sayfa yapısını oluşturamadım arkadaşlar.Rica etsem yeniden ekler misiniz ?

istanbulcahan · 2 Aralık 2008

ozgretmen' Alıntı:
Kodlar çok güzel...Ama örnek dosya inmiyor.Kodlardan da sayfa yapısını oluşturamadım arkadaşlar.Rica etsem yeniden ekler misiniz ?

Örnek dosyayı yeniden eklemenizi bende rica edeyim.

1Al2Ver · 2 Aralık 2008

Merhabalar,

1 nolu mesajda eklenen dosya, sadece üzerinde deneme yapılması amaçlıydı,

Dosya için yazılan kodu, boyutu 8.50 MB olan bir projemde kullandım,

Bu nedenle 1 nolu mesajdaki örnek dosyanın bir anlamı kalmadığı gibi, dosyayı bu haliyle de arşivlemedim,

Sorumda amacım, çalışma kitabının bir sayfasında ( Örn ; Sayfa1 ) belirlenen hücrelere ( Örn ;D2 : D50 ) resimlerin, HDD'deki yolunun ve adının kayıt edilmesi, diğer bir sayfada ( Örn ; Sayfa2 ) açılır kutu yardımı ile bir isim çağırılması ve bu yöntemle, seçilen isme ait resimin belirlenen başka bir aralıkta ( Örn ; Sayfa2'de B1:B9 ) açılması idi,

13 nolu mesajdaki kodda yeşil renkli ve önünde tırnak (') işareti bulunan satırlar açıklama satırıdır, açıklamaları okuyarak kendinize uyarlayabileceğinizi düşünüyorum,

Siz örnek bir dosya eklerseniz ve dosya benim yardımcı olabileceğim gibi ise ,çözüm bulmaya çalışırım, bulamazsam uzman arkadaşlarımızın sorunuza çözüm bulabileceklerinden eminim.

Teşekkür ederim.

Açılan Kutudan, Seçilen İsme Ait Resmin Gelmesi

1Al2Ver

Ferhat Pazarçevirdi

Özel Üye

1Al2Ver

limanC34

1Al2Ver

tahsinanarat

tahsinanarat

tahsinanarat

Ferhat Pazarçevirdi

Özel Üye

1Al2Ver

Ferhat Pazarçevirdi

Özel Üye

1Al2Ver

1Al2Ver

1Al2Ver

Ferhat Pazarçevirdi

Özel Üye

1Al2Ver

abazya

ozgretmen

istanbulcahan

1Al2Ver