在插入新图像之前删除所选范围内的所有图像

Question

I have the following code to insert multiple images in selected range:

Private Sub CommandButton1_Click()

Dim sPicture, PhotoCell() As Variant, pic As shape
Dim PictCell As Range
Dim fname As String
Dim I, x As Integer

    ActiveSheet.Unprotect Password:="123"
    On Error Resume Next

PhotoCell() = Array("K6:P17", "A19:D29", "L19:P29", "A30:D40", "L30:P40", "A41:D51", "L41:P51")
sPicture = Application.GetOpenFilename _
("Pictures (*.jpeg; *.gif; *.jpg; *.bmp; *.tif; *.png), *.jpeg; *.gif; *.jpg; *.bmp; *.tif", 0, "Select Photo", "OK", True)

x = 0
If IsArray(sPicture) Then
    
    For I = LBound(sPicture) To UBound(sPicture)
        
        fname = sPicture(I)
        If I Mod 2 = 1 Then
            Set PictCell = ActiveSheet.Range(PhotoCell(x))
            x = x + 1
        Else
            Set PictCell = ActiveSheet.Range(PhotoCell(x))
            x = x + 1
        End If
        
        Set pic = ActiveSheet.Shapes.AddPicture(fname, msoFalse, msoCTrue, 0, 0, 100, 100)

        pic.Delete

        With pic
            .LockAspectRatio = msoFalse
            .Height = PictCell.Height
            .Width = PictCell.Width
            .Top = PictCell.Top
            .Left = PictCell.Left
            .Placement = xlMoveAndSize
        End With
        Set pic = Nothing
    Next I

ActiveSheet.Protect Password:="123"

Else
          MsgBox "No Picture Selected"
End If
End Sub

however, I have lost all image objects when inserting this command

pic.Delete

so actually I want to replace the old image in the selected range with the new image and make sure that the old image is completely deleted.

Answer 1

Try something like this:

Private Sub CommandButton1_Click()
    Const PW As String = "123"
    Dim sPictures, sPic, PhotoCell() As Variant, pic As Shape
    Dim PictCell As Range
    Dim fname As String
    Dim x As Long, ws As Worksheet
    
    Set ws = ActiveSheet
    
    
    PhotoCell() = Array("K6:P17", "A19:D29", "L19:P29", "A30:D40", "L30:P40", "A41:D51", "L41:P51")
    sPictures = Application.GetOpenFilename( _
       "Pictures (*.jpeg; *.gif; *.jpg; *.bmp; *.tif; *.png), *.jpeg; *.gif; *.jpg; *.bmp; *.tif", 0, _
       "Select Photo", "OK", MultiSelect:=True)
    
    x = 0
    If IsArray(sPictures) Then
        ws.Unprotect PW
        For Each sPic In sPictures
            
            Set PictCell = ActiveSheet.Range(PhotoCell(x))
            x = x + 1
            RemovePicsInRange PictCell 'delete any existing shape in this range
            
            With ws.Shapes.AddPicture(sPic, msoFalse, msoCTrue, 0, 0, 100, 100)
                .LockAspectRatio = msoFalse
                .Height = PictCell.Height
                .Width = PictCell.Width
                .Top = PictCell.Top
                .Left = PictCell.Left
                .Placement = xlMoveAndSize
            End With
            
        Next sPic
        ActiveSheet.Protect Password:=PW
    Else
        MsgBox "No Picture Selected"
    End If
End Sub

'Delete any shapes whose TopLeftCell intersects with range `rng`
Sub RemovePicsInRange(rng As Range)
    Dim i As Long, allPics
    Set allPics = rng.Parent.Shapes
    For i = allPics.Count To 1 Step -1
        If Not Application.Intersect(allPics(i).TopLeftCell, rng) Is Nothing Then
            Debug.Print "Deleting shape at " & allPics(i).TopLeftCell.Address
            allPics(i).Delete
        End If
    Next i
End Sub