Sayfadaki Klasörden Çekilmiş Resimleri Makro ile Silme

[BedriA]

Arkadaşlar,

Ekteki dosyada, B sütununa, C diskindeki Sorular isimli klasör içindeki .jpg formatındaki resimlerin adını girince, A sütununa o resim geliyor.

Eklenen resimleri işim bittikten sonra bir makro ile silmek istiyorum ancak bir türlü makro oluşturamadım. Makro kaydetmeyi denedim, hiç bir şey kaydetmiyor. Klasördeki resimleri silip makro kaydettim, yine bir şey kaydetmedi.

Yardımcı olabilir misiniz?

Not: Ekteki dosya forumdan alınmıştır.
A sütununa resim eklenebilmesi için C diskinde .jpg formatında resimlerin olduğu Sorular isimli bir klasörün olması gerekiyor.

 

[askm]

Kodlarınızı aşağıdaki şekilde değiştirin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
Dim p As Object, t As Double, l As Double, w As Double, h As Double

ResimDosya = "C:\Sorular" & "\" & Target.Value & ".jpg"
'ResimDosya = "C:\Sorular" & "\" & Target.Offset(0, 1).Value & ".jpg"
If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)

With Cells(Target.Row, Target.Column - 1)
    t = .Top
    l = .Left
    w = .Offset(0, .Columns.Count).Left - .Left
    h = .Offset(.Rows.Count, 0).Top - .Top
End With

With p
    .Top = t
    .Left = l
    .Width = w
    .Height = h
End With

Set p = Nothing
Kill ResimDosya
End Sub

 

[halit3]

Benzer kodları size bir çok kez yazmıştım
kod:

Sub resimleri_sil()
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
End Sub

 

[BedriA]

Kodlarınızı aşağıdaki şekilde değiştirin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
Dim p As Object, t As Double, l As Double, w As Double, h As Double

ResimDosya = "C:\Sorular" & "\" & Target.Value & ".jpg"
'ResimDosya = "C:\Sorular" & "\" & Target.Offset(0, 1).Value & ".jpg"
If Dir(ResimDosya) = "" Then Exit Sub
Set p = ActiveSheet.Pictures.Insert(ResimDosya)

With Cells(Target.Row, Target.Column - 1)
    t = .Top
    l = .Left
    w = .Offset(0, .Columns.Count).Left - .Left
    h = .Offset(.Rows.Count, 0).Top - .Top
End With

With p
    .Top = t
    .Left = l
    .Width = w
    .Height = h
End With

Set p = Nothing
Kill ResimDosya
End Sub

Çok sağolun.

Silme işi nasıl olacak?

 

[BedriA]

Benzer kodları size bir çok kez yazmıştım
kod:

Sub resimleri_sil()
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
End Sub

O zaman bir kez daha teşekkür ederim.
Kod çalıştı.

 

[halit3]

ayrıca aşağıdaki linkdeki dosyanın Sayfa5 in kodlarını irdele

http://www.excel.web.tr/f128/resim-gosterme-secenekleri-t90172.html

 

[askm]

Ben klasörden silme olarak anlamıştım.

 

[BedriA]

Ben klasörden silme olarak anlamıştım.

Teşekkür ederim ilginiz için.

 

[BedriA]

ayrıca aşağıdaki linkdeki dosyanın Sayfa5 in kodlarını irdele

http://www.excel.web.tr/f128/resim-gosterme-secenekleri-t90172.html

Halit Hocam,

Bu çalışmanız bende çalışmıyor, kodları görebiliyorum ama gözlemleyemiyorum.
Bu çalışma her türlü ihtiyacıma cevap olurdu yoksa ki bu çalışmaya başlarken ilk indirdiğim çalışma bu oldu. Hâlâ duruyor ama gözlemleyemediğim için pek istifade edemedim.

 

[halit3]

Halit Hocam,

Bu çalışmanız bende çalışmıyor, kodları görebiliyorum ama gözlemleyemiyorum.
Bu çalışma her türlü ihtiyacıma cevap olurdu yoksa ki bu çalışmaya başlarken ilk indirdiğim çalışma bu oldu. Hâlâ duruyor ama gözlemleyemediğim için pek istifade edemedim.

İlgili link deki dosya ile ilgili sunu söylüyüm
dosyanın hemen yanında (Resimler) klasörü olmalı ve içindede resimler olmalı

 

[BedriA]

İlgili link deki dosya ile ilgili sunu söylüyüm
dosyanın hemen yanında (Resimler) klasörü olmalı ve içindede resimler olmalı

Deniyorum hemen Halit hocam.
Teşekkürler.

 

[BedriA]

Benzer kodları size bir çok kez yazmıştım
kod:

Sub resimleri_sil()
Dim s1
Set s1 = Sheets(ActiveSheet.Name)
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
End Sub

Halit Hocam,

Bu kodu bir buton ile "bes1", "sekiz1", "on1" sayfalarındaki resimleri aynı anda silecek şekilde nasıl değiştirebiliriz?

 

[halit3]

şunu bir dene

Sub resimleri_sil()

son = 3
ReDim sayfalar(son)
sayfalar(1) = "bes1"
sayfalar(2) = "sekiz1"
sayfalar(3) = "on1"

Dim Picture As Object

For i = 1 To son
For Each Picture In Sheets(sayfalar(i)).Shapes
If TypeName(Sheets(sayfalar(i)).Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
nexti
End Sub

 

[BedriA]

şunu bir dene

Sub resimleri_sil()

son = 3
ReDim sayfalar(son)
sayfalar(1) = "bes1"
sayfalar(2) = "sekiz1"
sayfalar(3) = "on1"

Dim Picture As Object

For i = 1 To son
For Each Picture In Sheets(sayfalar(i)).Shapes
If TypeName(Sheets(sayfalar(i)).Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
nexti
End Sub

Halit Hocam çalıştı, çok teşekkür ederim.