hücre seçilince pop-up resim penceresi açmak ?

[fevka]

Selamlar,

Hücre üzerine gelince pop-up tarzı açılır bir pencere ile hücre değerine göre resmin görünmesini istediğim bir dosya var. Forumdaki aramalarım neticesinde hücreye açıklama ekleyerek resim gösterilebildiğini gördüm fakat 30.000 satır için zahmetli bir iş olacak ekteki dosyanın satır sayısı yaklaşık 30.000 oluyor ve tek tek açıklama eklemek yerine VBA kod ile yapılabilir mi?

Şimdiden ilgilenen herkese teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz. Kırmızı renkli dosya yolunu kendi sisteminize göre değiştirmeyi unutmayın.

Option Explicit
 
Sub AÇIKLAMAYA_RESİM_EKLE()
    Dim X As Long, AÇIKLAMA As Comment, DOSYA_YOLU As String
    Dim RESİM As Object, GENİŞLİK As Integer, YÜKSEKLİK As Integer
    
    Application.ScreenUpdating = False
    
    For X = 2 To Cells(Rows.Count, 1).End(3).Row
        If Cells(X, 1) <> "" Then
[COLOR=red]            DOSYA_YOLU = "C:\Resimlerim\" & Cells(X, 1) & ".jpg"
[/COLOR]            
            Cells(X, 1).ClearComments
            Set AÇIKLAMA = Cells(X, 1).AddComment
            AÇIKLAMA.Text Text:=""
            
            If Dir(DOSYA_YOLU) <> "" Then
                Set RESİM = ActiveSheet.Pictures.Insert(DOSYA_YOLU)
                With RESİM
                    GENİŞLİK = .Width * 0.4
                    YÜKSEKLİK = .Height * 0.4
                    .Delete
                End With
                
                With AÇIKLAMA.Shape
                    .Fill.UserPicture DOSYA_YOLU
                    .Width = GENİŞLİK
                    .Height = YÜKSEKLİK
                End With

            Else
                
                With AÇIKLAMA
                    .Text Text:=Chr(10) & Chr(10) & "RESİM BULUNAMADI !"
                    .Shape.Fill.ForeColor.SchemeColor = 10
                    .Shape.TextFrame.Characters.Font.Bold = True
                    .Shape.TextFrame.Characters.Font.ColorIndex = 2
                End With
                
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[fevka]

Korhan Bey,

İlginize çok teşekkür ederim. Kod işlevini yerine getiriyor. Fakat küçük bir problem var.

resimleri 200*150 olarak değilde orijinal boyutunun % 50 veya %40 ı kadar küçük göster diye bir komut eklenebilir mi. Çünkü tüm resimler 200*150 ye uygunluk göstermediği için anlaması çok güç olan resimler oluşuyor.

 

[Korhan Ayhan]

Selamlar,

Üstteki mesjımdaki kodu güncelledim. İncelermisiniz.

 

[fevka]

Korhan Bey,

Ben nasıl düşünemedim. bu kadar kolay bişeyi.)

For X = 2 To Cells(Rows.Count, 1).End(3).Row

bu satırdaki döngü başlangıcı 2 den nereye kadar onu anlamadım.

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki koda küçük bir ekleme daha yaptım. Olmayan resimler için açıklama kutusu dolgu rengi kırmızı olacaktır. Bu şekilde olmayan resimleri daha rahat kontrol edebilirsiniz.

Diğer sorunuza gelince;

Döngü 2. satırdan "A" sütunundaki dolu olan en son satıra kadar devam etmektedir.

 

[fevka]

Korhan Bey,

Elinize sağlık, son düzenlemenizi de ekledim gayet şık oldu. Bunu diğer tablolarımda da kullanmaya çalıştım bir türlü "E" sütununda çalıştıramadım.

For X = 2 To Cells(Rows.Count, 1).End(3).Row

döngüdeki değerleri nasıl değiştirmem gerekecek?

Alakanız için tekrar teşekkürler.

 

[Korhan Ayhan]

Selamlar,

Kod içinde geçen bütün ", 1)" ifadelerini ", 5)" olarak değiştirin.

 

[fevka]

herşey için teşekkürler

10 numara oldu

 

[tahsinanarat]

Altarnatif

ilgili kodlar evvelce buradan temin ettiğim (yanılmıyorsam korhan hocama ve halit hocama ait) kodlardır. Altarnatif olsun diye ekliyorum. Kolay gelsin

 

[fevka]

İlginize teşekkür ederim,

Korhan Bey,
gönderdiğiniz kod çalışıyor, fakat şöyle bir sorun oluştu 1000 satırdan fazla bır tablo için dosya boyutu 50 mb'ı geçti. dosyayı kaydetmek dakikalar alıyor ve dosyayı mail olarak göndermek imkansız oldu.

kodu ve açıklamaları silmeme rağmen dosya boyutu hala 50 mb. bunu nasıl düzeltebiliriz?

Tahsin Bey,
Sizin gönderdiğiniz kod daha çok işime yaradı gibi en azından dosya boyutu 700 kb civarında. Ekteki dosya için ne gibi değişiklikler yapmam gerekiyor ben bu tablo yada uygulamaya çalıştım ama beceremedim.

 

[Korhan Ayhan]

Selamlar,

Sn. fevka,

İlk mesajınızda 30.000 satır veri oluyor diye belirmişsiniz. Excel sayfasına bir resim ekleyip kaydettiğinizde bile dosya boyutu büyük ölçüde artar. Sizin 30.000 satıra resim eklediğinizi düşünürsek dosyanızın boyutunun 50 MB 'lere çıkmış olması gayet doğaldır.

Dosya boyutunuzu küçültmek için aşağıdaki linki inceleyiniz.

Dosya boyutunu küçültmek

Tahsin beyin önerdiği dosyadaki kodlar sadece seçim yaptığınız hücreye ait resimleri dosyanıza yükler. Başka bir hücre seçtiğinizde ilk resim silinir ve yeni seçtiğiniz hücreye ait resim yüklenir. Eğer bu yönde çözüm işinize yarıyorsa Tahsin beyin önerdiği dosyayıda kullanabilirsiniz.

 

[tahsinanarat]

Dosyanız ektedir

Foto adres satırı u1 (yani 21.sutun) farklı yere taşırsanız aşağıdaki 21 leri ona göre düzenlersiniz.
If Dir(Cells(1, 21) & Target.Offset(0, 0).Value & ".JPG") <> "" Then
Image1.Picture = LoadPicture(Cells(1, 21) & Target.Offset(0, 0).Value & ".JPG")

 

[fevka]

Tahsin Bey,

Her şey için tekrar teşekkür ederim. biraz önce toparladım dosyayı herşey dört dörtlük. Klavyenize sağlık