Klasör içerisinde resmi olmayanlar boş görünsün

tahsinanarat · 19 Şubat 2009

Ekli dosyada, a sutununda bulunan kodlara ait olan D:\Foto klasöründe aynı kodlarla adlandırılmış resimler bulunmakta olup, B sutununda hücrelerde gezinirken solda (a sutununda) bulunan hücredeki koda ait resim görüntülenmektedir. Buraya kadar herşey tamam.
Ancak bu koda ait resim dosyasında resim yok ise bir önceki resim görüntüde kalmakta, ben ise hiç bir görüntünün olmamasını eğer bu olmuyor ise en azından görüntünün boş gelmesini istiyorum.
Dosya içindeki kodlar: (sn.janveljan'a aittir)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [B:B]) Is Nothing Then GoTo son
If Target.Address = "$B$1" Then Exit Sub
If Target.Offset(0, -1).Value & ".JPG" <> "" Then
If UCase(Right(Target.Offset(0, -1).Value & ".JPG", 3)) = "JPG" Or UCase(Right(Target.Offset(0, -1).Value & ".BMP", 3)) = "BMP" Then
Image1.Top = Target.Offset(0, 1).Top
Image1.Left = Target.Offset(0, 1).Left
If Not Image1.Visible Then Image1.Visible = True
Image1.Picture = LoadPicture(Cells(1, 1) & Target.Offset(0, -1).Value & ".JPG")
Else
GoTo son
End If
End If
Exit Sub
son:
Image1.Visible = False
Image1.Picture = Nothing
End Sub

Yardımcı olacak arkadaşlarıma şimdiden teşekkür ediyorum.

Korhan Ayhan · 20 Şubat 2009

Selamlar,

Kodunuzu aşağıdaki şekilde değiştirip denermisiniz.

Kod:

Option Explicit
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [B:B]) Is Nothing Then GoTo son
    If Target.Address = "$B$1" Then Exit Sub
    If Target.Offset(0, -1).Value & ".JPG" <> "" Then
    If UCase(Right(Target.Offset(0, -1).Value & ".JPG", 3)) = "JPG" Or UCase(Right(Target.Offset(0, -1).Value & ".BMP", 3)) = "BMP" Then
    Image1.Top = Target.Offset(0, 1).Top
    Image1.Left = Target.Offset(0, 1).Left
    If Not Image1.Visible Then Image1.Visible = True
    If Dir(Cells(1, 1) & Target.Offset(0, -1).Value & ".JPG") <> "" Then
    Image1.Picture = LoadPicture(Cells(1, 1) & Target.Offset(0, -1).Value & ".JPG")
    [COLOR=red][B]Image1.AutoSize = True[/B][/COLOR]
    Else
    Image1.Picture = Empty
    Image1.Visible = False
    Image1.Picture = Nothing
    End If
    Else
    GoTo son
    End If
    End If
    Exit Sub
son:
    Image1.Visible = False
    Image1.Picture = Nothing
End Sub

tahsinanarat · 20 Şubat 2009

Sn. Korhan Ayhan hocam, elinize sağlık tam istediğim gibi olmuş, çok teşekkür ederim.

tahsinanarat · 20 Şubat 2009

Sn. Korhan Ayhan hocam, image görüntüsüne gelen resmin boyutunu tamamen görebilmek mümkünmüdür, bazı resimlerin bir kısmı görünmüyor. Saygılar.

Korhan Ayhan · 20 Şubat 2009

Selamlar,

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

cevatyildiz · 20 Şubat 2009

hocam bu resimleri A sütunundaki rakamların üzerine geldiğimizde çıkması için kodu nasıl değiştirebiliriz?

janveljan · 20 Şubat 2009

Kod:

Option Explicit
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [A:A]) Is Nothing Then GoTo son
    If Target.Address = "$A$1" Then Exit Sub
    If Target.Value & ".JPG" <> "" Then
    If UCase(Right(Target.Value & ".JPG", 3)) = "JPG" Or UCase(Right(Target.Value & ".BMP", 3)) = "BMP" Then
    Image1.Top = Target.Offset(0, 1).Top
    Image1.Left = Target.Offset(0, 1).Left
    If Not Image1.Visible Then Image1.Visible = True
    If Dir(Cells(1, 1) & Target.Value & ".JPG") <> "" Then
    Image1.Picture = LoadPicture(Cells(1, 1) & Target.Value & ".JPG")
    Image1.AutoSize = True
    Else
    Image1.Picture = Empty
    Image1.Visible = False
    Image1.Picture = Nothing
    End If
    Else
    GoTo son
    End If
    End If
    Exit Sub
son:
    Image1.Visible = False
    Image1.Picture = Nothing
End Sub

şeklinde değiştirin. (Ezberden değiştiriyorum umarım hata çıkmaz.)

cevatyildiz · 20 Şubat 2009

Verdiğiniz şekilde çalıştı sağolun hocam..

tahsinanarat · 21 Şubat 2009

sn. korhan hocam elinize sağlık, çok mükemmel oldu, eminim bu kadlar çok kişinin işine yarayacaktır. Allah sizden razı olsun. Saygılar hocam.

cevatyildiz · 21 Şubat 2009

Hocam başka bir sayfada bu kodları kullanmak istiyorum üzerine geldiğimde resimlerin gözükmesini istediğim bilgiler D sütununda 3. satırdan başlıyor.(Target [D

]) Kaynak dosyaları da $AA$1 de gösterdim ama sayfada herhangi bir yere tıkladıgımda "Image1" için compile error veriyor. Variable not defined... Problem nerede?

janveljan · 21 Şubat 2009

Baştaki Option Explicit deyimini kaldırın
Birde aşağıdaki satırda Cells(1,1) dosyaların yolunu gösteriyor, "Kaynak dosyaları da $AA$1 de gösterdim" demişsiniz kastettiğiniz dosya yolu ile aşağıdaki satırda gerekli düzenlemeyi yapmanız lazım.

Kod:

Image1.Picture = LoadPicture(Cells(1, 1) & Target.Value & ".JPG")

cevatyildiz · 21 Şubat 2009

Hocam bir kontrol edebilri misiniz?

janveljan · 21 Şubat 2009

İlgili sayfaya bir image nesnesi eklenmesi lazım esas problem ordaydı onu ekledim, diğer problem de dosya yolunu bir yerde düzeltmişsiniz bir yerde düzelmemişsiniz onu da düzelttim, şöyle bir sıkıntı olabilir, dosya isimlerini elle girdiğiniz için format farkından dolayı veya uzantı farkından dolayı problem çıkabilir.

cevatyildiz · 21 Şubat 2009

hocam dosya format ve uzantılarında problem yok. ama gonderdiğiniz dosya çalışmıyor. İmage nesnesi derken Resim-Dosyadan herhangi bir Resim ekle mi yapılması gerekli?

cevatyildiz · 21 Şubat 2009

Bu şekilde çalıştırdım hocam ama yine başka bir sayfaya aktardım aynı kodları yine çalışmıyor. Bu resim nesnesi ekleme nedir?

Kod:

Option Explicit
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [D:D]) Is Nothing Then GoTo son
    If Target.Address = "$D$1" Then Exit Sub
    If Target.Value & ".JPG" <> "" Then
    If UCase(Right(Target.Value & ".JPG", 3)) = "JPG" Or UCase(Right(Target.Value & ".BMP", 3)) = "BMP" Then
    Image1.Top = Target.Offset(0, 1).Top
    Image1.Left = Target.Offset(0, 1).Left
    If Not Image1.Visible Then Image1.Visible = True
    If Dir(Cells(1, 27) & Target.Value & ".JPG") <> "" Then
    Image1.Picture = LoadPicture(Cells(1, 27) & Target.Value & ".JPG")
    Image1.AutoSize = True
    Else
    Image1.Picture = Empty
    Image1.Visible = False
    Image1.Picture = Nothing
    End If
    Else
    GoTo son
    End If
    End If
    Exit Sub
son:
    Image1.Visible = False
    Image1.Picture = Nothing
End Sub

janveljan · 21 Şubat 2009

Başka sayıya aktarınca çalışmaz, sayfanın üzerinde iken vbasic araç çubuğunu görünür yapıp, burdan, denetim araç kutusunu açıp image nesnesi eklemeniz gerekir. Birde benim gönderdiğim dosyadaki kodları kullanın şu an kullandıklarınızda gereksiz veya yanlış satırlar var. Örnek:

Kod:

If Target.Value & ".JPG" <> "" Then

Bu kodda değere ".JPG" eklediğiniz için hiçbir zaman boş olamaz ki

cevatyildiz · 21 Şubat 2009

Hocam, image nesnesini şimdi anladım tesekkurler...ama yine de sizin verdiğiniz kod çalışmıyor :-(

ridvan2111 · 21 Şubat 2009

7. mesajdaki kodlarda değişiklik

selam arkadaşlar
7. mesajdaki janveljan arkadaşın kodlarında bu şekilde bir değişiklik yapılabilirmi?
(7. mesaj kodları aşagıda)
a sütünuna d:foto klasöründeki *.jpg dosya isimlerini otomatik sırayalasın
a sutununda dosya ismine tıkladığımızda resim görünsün veya windows resim görüntüleyicide açsın resimde yazdırma, düzenleme vs. gibi işlemler yapılabilmesi açısından.

Kod:

Option Explicit
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [A:A]) Is Nothing Then GoTo son
    If Target.Address = "$A$1" Then Exit Sub
    If Target.Value & ".JPG" <> "" Then
    If UCase(Right(Target.Value & ".JPG", 3)) = "JPG" Or UCase(Right(Target.Value & ".BMP", 3)) = "BMP" Then
    Image1.Top = Target.Offset(0, 1).Top
    Image1.Left = Target.Offset(0, 1).Left
    If Not Image1.Visible Then Image1.Visible = True
    If Dir(Cells(1, 1) & Target.Value & ".JPG") <> "" Then
    Image1.Picture = LoadPicture(Cells(1, 1) & Target.Value & ".JPG")
    Image1.AutoSize = True
    Else
    Image1.Picture = Empty
    Image1.Visible = False
    Image1.Picture = Nothing
    End If
    Else
    GoTo son
    End If
    End If
    Exit Sub
son:
    Image1.Visible = False
    Image1.Picture = Nothing
End Sub

cimbom05 · 23 Şubat 2009

Sayı janjelvan
Buradan alınan kodlar ile bir dosya oluşturdum ve çok güzel bir şekilde çalıştı. Ancak oluşturduğum bu dosyayı başka bir pc de açlıştıramadım. Sayfadaki image nesnesi açılıyor ancak içine resim gelmiyor. İmage nesnesinin içeriği gri bir arka plana sahip kalıyor. Kod sayfasından preferences içerisinden seçili olanları, makro güvenlik düzeyini kontrol ettim. Her iki pc'de aynı olmasına rağmen dosya çalışmıyor. Dosyada ne gibi bir değişiklik yapmalıyım acaba?

janveljan · 23 Şubat 2009

Kodlar belirli aralıklarda çalışmak için düzenlenmiştir, bu nedenle dosya ismi yazılırken bu aralıklara yazılmalıdır. Sizin dosyanızı düzenledim. Kodların son durumu şu şekilde;

Kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    'On Error Resume Next
    If Intersect(Target, [B2:B65536]) Is Nothing Then GoTo son
    
    isim = Target.Value
    yol = Cells(1, 1)
    uzantı = ".JPG"
    
    If isim <> "" Then
        Image1.Top = Target.Offset(0, 2).Top
        Image1.Left = Target.Offset(0, 2).Left
        If Not Image1.Visible Then Image1.Visible = True
        If Dir(yol & isim & uzantı) <> "" Then
        Image1.Picture = LoadPicture(yol & isim & uzantı)
        Image1.AutoSize = True
        Else
        Image1.Picture = Empty
        Image1.Visible = False
        Image1.Picture = Nothing
        End If
    Else
        GoTo son
    End If
    Exit Sub
son:
    Image1.Visible = False
    Image1.Picture = Nothing
End Sub

Değişiklik yapılması gereken noktalar:
İsimlerin yazdığı aralık değişirse

Kod:

If Intersect(Target, [B2:B65536]) Is Nothing Then GoTo son

Dosya yolu veya dosya uzantısı değişecek ise

Kod:

uzantı = ".JPG"
yol = Cells(1, 1)

Klasör içerisinde resmi olmayanlar boş görünsün

tahsinanarat

Ekli dosyalar

Korhan Ayhan

Administrator

tahsinanarat

tahsinanarat

Korhan Ayhan

Administrator

cevatyildiz

janveljan

cevatyildiz

tahsinanarat

cevatyildiz

janveljan

cevatyildiz

Ekli dosyalar

janveljan

Ekli dosyalar

cevatyildiz

cevatyildiz

janveljan

Ekli dosyalar

cevatyildiz

ridvan2111

cimbom05

Ekli dosyalar

janveljan

Ekli dosyalar