- Katılım
- 8 Nisan 2008
- Mesajlar
- 60
- Excel Vers. ve Dili
- Ofis 2019 Türkçe 64 Bit
Aşağıdaki kodlar sayfaya eklenen resimlerin tamamını siliyor. Ben sadece belirli hücrelerdeki resimleri silmesini istiyorum. Yardımcı olursanız sevinirim. Teşekkürler
Public Function DosyaVarmi(dosyayolu As String) As Boolean
On Error GoTo Çıkış
If Not Dir(dosyayolu, vbDirectory) = vbNullString Then DosyaVarmi = True
Çıkış:
On Error GoTo 0
End Function
'worksheette bir değişiklik oldugunda bu kısım çalışıyor
Private Sub Worksheet_Change(ByVal Target As Range)
Sheets("Sonuç Ekranı").Unprotect "1"
'değişiklik b sutunundamı olmuş diye kontrol et, değilse direk olarak fonksiyondan çık
If Intersect(Target, [c:c]) Is Nothing Then Exit Sub
'herhangi bir hata oluşursa Çıkış labelına git
On Error GoTo Çıkış:
' ilk olarak yüklü olan Resimleri silelim
ActiveSheet.DrawingObjects.Delete
Dim ResimDosyaYolu As String
Dim Resim As Object
'b deki 5 ile 12 arasındaki satırları kontrol edip resim ataması yapıyoruz, siz burayı isteğinize göre artırabilirsiniz
For i = 1 To 1
'aktif sayfanın path bilgisini alıp, seçilen ürün idyi sonuna ekliyoruz ve dosyayı alıyoruz
ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("c" & i) & ".jpg"
'dosya yok ise hataya düşmemek için aşağıdaki kontrolü yapıyoruz.
If DosyaVarmi(ResimDosyaYolu) Then
ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("c" & i) & ".jpg"
Else
ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
End If
'resmi oluşturuyoruz.
Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
'Resmi boyutlandırıyoruz
With Range("a" & i)
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With
Next i
Çıkış:
Sheets("Sonuç Ekranı").Protect "1"
End Sub
Public Function DosyaVarmi(dosyayolu As String) As Boolean
On Error GoTo Çıkış
If Not Dir(dosyayolu, vbDirectory) = vbNullString Then DosyaVarmi = True
Çıkış:
On Error GoTo 0
End Function
'worksheette bir değişiklik oldugunda bu kısım çalışıyor
Private Sub Worksheet_Change(ByVal Target As Range)
Sheets("Sonuç Ekranı").Unprotect "1"
'değişiklik b sutunundamı olmuş diye kontrol et, değilse direk olarak fonksiyondan çık
If Intersect(Target, [c:c]) Is Nothing Then Exit Sub
'herhangi bir hata oluşursa Çıkış labelına git
On Error GoTo Çıkış:
' ilk olarak yüklü olan Resimleri silelim
ActiveSheet.DrawingObjects.Delete
Dim ResimDosyaYolu As String
Dim Resim As Object
'b deki 5 ile 12 arasındaki satırları kontrol edip resim ataması yapıyoruz, siz burayı isteğinize göre artırabilirsiniz
For i = 1 To 1
'aktif sayfanın path bilgisini alıp, seçilen ürün idyi sonuna ekliyoruz ve dosyayı alıyoruz
ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("c" & i) & ".jpg"
'dosya yok ise hataya düşmemek için aşağıdaki kontrolü yapıyoruz.
If DosyaVarmi(ResimDosyaYolu) Then
ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("c" & i) & ".jpg"
Else
ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
End If
'resmi oluşturuyoruz.
Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
'Resmi boyutlandırıyoruz
With Range("a" & i)
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With
Next i
Çıkış:
Sheets("Sonuç Ekranı").Protect "1"
End Sub