Soru Sadece Dosyadan Seçilen Resimleri Silmek

Hsn55 · 13 Kasım 2021

Merhabalar; ekli dosyada ki resim butonunu tıkladığımda seçmiş olduğum 1 veya 1 den fazla resim birleştirilerek ana sayfa ve resim sayfasına geliyor. Tekrar resim butonundan resim seçip eklediğimde bir önceki eklenen resimleri ve sayfalardaki (anasayfa ve resim) tüm image nesnelerini de siliyor. Benim istediğim resim eklediğimizde bir önceki eklenen resimlerin silinmesi sayfadaki diğer resimlerin kalması .Şimdiden yardımlarınız için teşekkür ederim.
https://dosyam.org/Zng/RESİM_BİRLEŞTİR_(1).xlsm

Kod:

Sub PicturesInsertMultiMerge()
Dim Pic As Object, File As Variant, Sht As Worksheet
Dim RngArr, RngArr1 As Range, FlCnt&, SmFl&
ChDrive Environ("SystemDrive"): ChDir Environ("UserProfile") & "\Desktop"

Set Sht = Sheets("RESİM"): Set RngArr = Sht.[C12:V50]
Set s1 = Sheets("ANA SAYFA"): Set RngArr1 = s1.[m5:p16]

File = Application.GetOpenFilename( _
    "Resim Dosyaları (*.jfif;*.jpg;*.jpeg;*.png;*.bmp),*.jpg;*.jpeg;*.png;*.bmp ;*.jfif" & _
    ",Tüm Dosyalar (*.*),*.*", , "Resim Dosyası Seçin...", , True)
If Not IsArray(File) Then Exit Sub
For Each Pic In Sht.Shapes
    If Pic.Type <> 1 Then
        Sht.Shapes(Pic.Name).Delete
    End If
Next Pic

For Each Pic1 In s1.Shapes
    If Pic1.Type <> 1 Then
        s1.Shapes(Pic1.Name).Delete
    End If
Next Pic1
SmFl = UBound(File)
For FlCnt = 1 To SmFl Step 1
    On Error GoTo ExitSub
    Set Pic = Sht.Pictures.Insert(File(FlCnt))
    With Pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Placement = xlFreeFloating
        .Width = IIf(SmFl < 3, RngArr.Width, IIf(SmFl Mod 2 And SmFl = FlCnt, RngArr.Width, RngArr.Width / 2))
        .Height = RngArr.Height / IIf(SmFl > 2, (SmFl - ((SmFl + 1) Mod 2) + 1) / 2, 1) * IIf(SmFl = 2, 0.5, 1)
        .Top = RngArr.Top + (.Height * (FlCnt - ((FlCnt - 1) Mod 2) - 1) / 2) + IIf(SmFl = 2 And SmFl = FlCnt, .Height, 0)
        .Left = RngArr.Left + (.Width * ((FlCnt - 1) Mod 2)) - IIf(SmFl = 2 And SmFl = FlCnt, .Width, 0)
     With .ShapeRange.Line 'çerçeve
    .Visible = msoTrue 'çerçeveyi göster
    .ForeColor.RGB = 16777515 'çerçeve rengi
    .Weight = 3 'çerçeve kalınlığı
     End With
    End With
    
        Set Pic1 = s1.Pictures.Insert(File(FlCnt))
    With Pic1
        .ShapeRange.LockAspectRatio = msoFalse
        .Placement = xlFreeFloating
        .Width = IIf(SmFl < 3, RngArr1.Width, IIf(SmFl Mod 2 And SmFl = FlCnt, RngArr1.Width, RngArr1.Width / 2))
        .Height = RngArr1.Height / IIf(SmFl > 2, (SmFl - ((SmFl + 1) Mod 2) + 1) / 2, 1) * IIf(SmFl = 2, 0.5, 1)
        .Top = RngArr1.Top + (.Height * (FlCnt - ((FlCnt - 1) Mod 2) - 1) / 2) + IIf(SmFl = 2 And SmFl = FlCnt, .Height, 0)
        .Left = RngArr1.Left + (.Width * ((FlCnt - 1) Mod 2)) - IIf(SmFl = 2 And SmFl = FlCnt, .Width, 0)
     With .ShapeRange.Line 'çerçeve
    .Visible = msoTrue 'çerçeveyi göster
    .ForeColor.RGB = 16777515 'çerçeve rengi
    .Weight = 3 'çerçeve kalınlığı
     End With
    End With
    
    
Next FlCnt
ExitSub:
Set Pic = Nothing: Set Sht = Nothing: Set File = Nothing

End Sub

Muzaffer Ali · 13 Kasım 2021

Merhaba.
Aşağıdaki satırları silmeniz yeterli.
Aşağıdaki RESİM sayfasındaki resimleri siliyor

Kod:

For Each Pic In Sht.Shapes
    If Pic.Type <> 1 Then
        Sht.Shapes(Pic.Name).Delete
    End If
Next Pic

Aşağıdaki ANASAYFA sayfasındaki resimleri siliyor

Kod:

For Each Pic1 In s1.Shapes
    If Pic1.Type <> 1 Then
        s1.Shapes(Pic1.Name).Delete
    End If
Next Pic1

Hsn55 · 13 Kasım 2021

Sayın Muzaffer bey merhabalar; dediğinizi yaptım. Evet sayfaya eklenen resimleri silmiyor. Fakat dosyadan eklenenleri de silmiyor. Devamlı resimleri üzerine ekliyor. Bir önceki eklenen resimleri silmesi gerekiyor

halit3 · 13 Kasım 2021

bu kodu çalıştırın
kod
A Sutununa resimin sayısal değerini yazıyor
B Sutununa resimin adını yazıyor.

şua n kod 12 , 8 ,2 değerlerini siliyor
ancak silme bölümü pasif olarak ekliyorum kodu kendinize göre düzenleyiniz.

CSS:

Sub deneme()

Set s1 = Sheets("ANA SAYFA")
For Each Pic In s1.Shapes
sat = sat + 1
Cells(sat, 1) = Pic.Type
Cells(sat, 2) = Pic.Name
If Pic.Type = 12 Or Pic.Type = 8 Or Pic.Type = 2 Then
's1.Shapes(Pic.Name).Delete
End If
Next Pic

End Sub

Hsn55 · 13 Kasım 2021

Muzaffer bey kodu çalıştıramadım. Diğer kodları silecekmiyim.

Muzaffer Ali · 13 Kasım 2021

Aşağıdaki kodlar yeni bir module kopyalayın.
Önceki kodları silebilirsiniz.

Kod:

Dim FotoS1 As Variant, FotoSht As Variant
Dim Sht As Worksheet, S1 As Worksheet

Sub Auto_Close()

If Not TypeName(FotoS1) = "Empty" Then
    For Bak = 0 To UBound(FotoS1)
        On Error Resume Next
        FotoS1(Bak).Delete
        FotoSht(Bak).Delete
    Next
End If
ThisWorkbook.Save
End Sub


Sub PicturesInsertMultiMerge2()
Dim Bak As Integer
Dim Pic As Object, File As Variant
Dim RngArr, RngArr1 As Range, FlCnt&, SmFl&
ChDrive Environ("SystemDrive"): ChDir Environ("UserProfile") & "\Desktop"
Set Sht = Sheets("RESİM"): Set RngArr = Sht.[C12:V50]
Set S1 = Sheets("ANA SAYFA"): Set RngArr1 = S1.[m5:p16]
Call Auto_Close
File = Application.GetOpenFilename( _
    "Resim Dosyaları (*.jfif;*.jpg;*.jpeg;*.png;*.bmp),*.jpg;*.jpeg;*.png;*.bmp ;*.jfif" & _
    ",Tüm Dosyalar (*.*),*.*", , "Resim Dosyası Seçin...", , True)
If Not IsArray(File) Then Exit Sub
SmFl = UBound(File)
ReDim FotoS1(1) As Variant
ReDim FotoSht(1) As Variant
For FlCnt = 1 To SmFl Step 1
    On Error GoTo ExitSub
    Set Pic = Sht.Pictures.Insert(File(FlCnt))
    With Pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Placement = xlFreeFloating
        .Width = IIf(SmFl < 3, RngArr.Width, IIf(SmFl Mod 2 And SmFl = FlCnt, RngArr.Width, RngArr.Width / 2))
        .Height = RngArr.Height / IIf(SmFl > 2, (SmFl - ((SmFl + 1) Mod 2) + 1) / 2, 1) * IIf(SmFl = 2, 0.5, 1)
        .Top = RngArr.Top + (.Height * (FlCnt - ((FlCnt - 1) Mod 2) - 1) / 2) + IIf(SmFl = 2 And SmFl = FlCnt, .Height, 0)
        .Left = RngArr.Left + (.Width * ((FlCnt - 1) Mod 2)) - IIf(SmFl = 2 And SmFl = FlCnt, .Width, 0)
     With .ShapeRange.Line 'çerçeve
    .Visible = msoTrue 'çerçeveyi göster
    .ForeColor.RGB = 16777515 'çerçeve rengi
    .Weight = 3 'çerçeve kalınlığı
     End With
    End With
        Set Pic1 = S1.Pictures.Insert(File(FlCnt))
    With Pic1
        .ShapeRange.LockAspectRatio = msoFalse
        .Placement = xlFreeFloating
        .Width = IIf(SmFl < 3, RngArr1.Width, IIf(SmFl Mod 2 And SmFl = FlCnt, RngArr1.Width, RngArr1.Width / 2))
        .Height = RngArr1.Height / IIf(SmFl > 2, (SmFl - ((SmFl + 1) Mod 2) + 1) / 2, 1) * IIf(SmFl = 2, 0.5, 1)
        .Top = RngArr1.Top + (.Height * (FlCnt - ((FlCnt - 1) Mod 2) - 1) / 2) + IIf(SmFl = 2 And SmFl = FlCnt, .Height, 0)
        .Left = RngArr1.Left + (.Width * ((FlCnt - 1) Mod 2)) - IIf(SmFl = 2 And SmFl = FlCnt, .Width, 0)
     With .ShapeRange.Line 'çerçeve
    .Visible = msoTrue 'çerçeveyi göster
    .ForeColor.RGB = 16777515 'çerçeve rengi
    .Weight = 3 'çerçeve kalınlığı
     End With
    End With
    
        ReDim Preserve FotoS1(FlCnt - 1)
        Set FotoS1(FlCnt - 1) = Pic1
        ReDim Preserve FotoSht(FlCnt - 1)
        Set FotoSht(FlCnt - 1) = Pic
        
Next FlCnt
ExitSub:
Set Pic = Nothing: Set Sht = Nothing: Set File = Nothing

End Sub

Hsn55 · 13 Kasım 2021

Muzaffer bey çok teşekkür ederim. Kod gayet güzel çalışıyor. Aynı makroya rica etsem aşağıdaki sayfaları da ilavesi yapabilir misiniz?

Sheets("ANA SAYFA"): Set RngArr1 = S1.[M5

16]
Sheets("RESİM"): Set RngArr = Sht.[C12:V50]
Sheets("KADASTRO"): Set RngArr = Sht.[C12:V50]
Sheets("AMENAJMAN"): Set RngArr = Sht.[C12:V50]
Sheets("MEMLEKET"): Set RngArr = Sht.[C12:V50]
Sheets("KROKİ"): Set RngArr = Sht.[C12:V50]

Muzaffer Ali · 13 Kasım 2021

Bunların hepsine aynı fotoğraflar eklensin ve silinsin mi istiyorsunuz?

Hsn55 · 13 Kasım 2021

Muzaffer Ali · 13 Kasım 2021

Kod:

Option Explicit
Dim Foto
Dim Sayfalar As Variant

Sub Auto_Close()
    Dim Bak As Integer
    Dim BakSyf As Integer
    On Error Resume Next
    If Not TypeName(Foto) = "Empty" Then
        For BakSyf = 0 To UBound(Sayfalar)
            For Bak = 0 To UBound(Foto)
                Worksheets(Sayfalar(BakSyf)).Pictures(Foto(Bak)).Delete
            Next
        Next
    End If
End Sub


Sub PicturesInsertMultiMerge2()
    Dim Bak As Integer
    Dim BakSyf As Integer
    Dim Pic As Picture, File As Variant
    Dim RngArr1, RngArr As Range
    Dim SmFl&
    '_________________________________________________________________________________________________
    'Sayfa ekleyip çıkarmak isterseniz burayı değiştirin.
    Sayfalar = Array("ANA SAYFA", "RESİM", "KADASTRO", "AMENAJMAN", "MEMLEKET", "KROKİ")
    '_________________________________________________________________________________________________
    ChDrive Environ("SystemDrive"): ChDir Environ("UserProfile") & "\Desktop"
    Set RngArr1 = Worksheets("RESİM").[C12:V50]
    Set RngArr = Worksheets("ANA SAYFA").[M5:p16]
    Call Auto_Close
    ReDim Foto(0)
    File = Application.GetOpenFilename( _
        "Resim Dosyaları (*.jfif;*.jpg;*.jpeg;*.png;*.bmp),*.jpg;*.jpeg;*.png;*.bmp ;*.jfif" & _
        ",Tüm Dosyalar (*.*),*.*", , "Resim Dosyası Seçin...", , True)
    If Not IsArray(File) Then Exit Sub
    SmFl = UBound(File)
    For Bak = 1 To SmFl Step 1
        Set Pic = Sheets("ANA SAYFA").Pictures.Insert(File(Bak))
        ReDim Preserve Foto(Bak - 1)
        Foto(Bak - 1) = "Foto" & Bak
        With Pic
            .Name = "Foto" & Bak
            .ShapeRange.LockAspectRatio = msoFalse
            .Placement = xlFreeFloating
            .Width = IIf(SmFl < 3, RngArr1.Width, IIf(SmFl Mod 2 And SmFl = Bak, RngArr1.Width, RngArr1.Width / 2))
            .Height = RngArr1.Height / IIf(SmFl > 2, (SmFl - ((SmFl + 1) Mod 2) + 1) / 2, 1) * IIf(SmFl = 2, 0.5, 1)
            .Top = RngArr1.Top + (.Height * (Bak - ((Bak - 1) Mod 2) - 1) / 2) + IIf(SmFl = 2 And SmFl = Bak, .Height, 0)
            .Left = RngArr1.Left + (.Width * ((Bak - 1) Mod 2)) - IIf(SmFl = 2 And SmFl = Bak, .Width, 0)
                With .ShapeRange.Line 'çerçeve
                    .Visible = msoTrue 'çerçeveyi göster
                    .ForeColor.RGB = 16777515 'çerçeve rengi
                    .Weight = 3 'çerçeve kalınlığı
                End With
        End With
        
        For BakSyf = 1 To UBound(Sayfalar)
            Set Pic = Sheets(Sayfalar(BakSyf)).Pictures.Insert(File(Bak))
            With Pic
                .Name = "Foto" & Bak
                .ShapeRange.LockAspectRatio = msoFalse
                .Placement = xlFreeFloating
                .Width = IIf(SmFl < 3, RngArr.Width, IIf(SmFl Mod 2 And SmFl = Bak, RngArr.Width, RngArr.Width / 2))
                .Height = RngArr.Height / IIf(SmFl > 2, (SmFl - ((SmFl + 1) Mod 2) + 1) / 2, 1) * IIf(SmFl = 2, 0.5, 1)
                .Top = RngArr.Top + (.Height * (Bak - ((Bak - 1) Mod 2) - 1) / 2) + IIf(SmFl = 2 And SmFl = Bak, .Height, 0)
                .Left = RngArr.Left + (.Width * ((Bak - 1) Mod 2)) - IIf(SmFl = 2 And SmFl = Bak, .Width, 0)
                With .ShapeRange.Line 'çerçeve
                    .Visible = msoTrue 'çerçeveyi göster
                    .ForeColor.RGB = 16777515 'çerçeve rengi
                    .Weight = 3 'çerçeve kalınlığı
                End With
            End With
        Next BakSyf
    Next Bak
End Sub

halit3 · 13 Kasım 2021

Resim sil kodları böyle olabilir

Kod:

sat1 = 11
sat2 = 52
sut1 = 3
sut2 = 22

For Each Pic In sht.Shapes
If TypeName(sht.Shapes(Pic.Name).OLEFormat.Object) = "Picture" Then
If Pic.TopLeftCell.Row >= sat1 And Pic.BottomRightCell.Row <= sat2 Then
If Pic.TopLeftCell.Column >= sut1 And Pic.BottomRightCell.Column <= sut2 Then
Pic.Delete
End If
End If
End If
Next Pic

Soru Sadece Dosyadan Seçilen Resimleri Silmek

Hsn55

Muzaffer Ali

Destek Ekibi

Hsn55

halit3

Uzman

Hsn55

Muzaffer Ali

Destek Ekibi

Hsn55

Muzaffer Ali

Destek Ekibi

Hsn55

Muzaffer Ali

Destek Ekibi

halit3

Uzman