Image/Shape Delete

[RichieL]

Goedenavond,

Ik heb bijgevoegde VBA script. De volgende uitdaging.

Wanneer D1 wijzigt dan veranderd ook de URL in H18. Wanneer deze wijzigt dan wijzigt ook de foto. Alleen blijft de oude foto onder de nieuwe foto staan.
Nu had ik activesheet.pictures.delete geplaatst vooraan in het script, maar dan verwijderd hij ook het Google logo (zoals in de het voorbeeld).

Hij moet allen de foto in H18 verwijderen en dan de nieuw plaatsen. Het logo van Google moet blijven staan.

Hoe kan ik dit het beste beetpakken?

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$1" Then
    On Error Resume Next
    'activesheet.pictures.delete ==> Staat uit.
    Dim Pshp As Shape
    Dim xRg As Range
    Dim xCol As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    Set rng = ActiveSheet.Range("H18:H18")
    For Each cell In rng
        filenam = cell
        ActiveSheet.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        Pshp.Placement = xlMoveAndSize
        If Pshp Is Nothing Then GoTo lab
        xCol = cell.Column + 1
        xRow = cell.Row + 5
        Set xRg = Cells(cell.Row, xCol)
        With Pshp
            .LockAspectRatio = msoFalse
            .Width = 350
           .Height = 350
            .Top = xRg.Top + (xRg.Height - .Height) / 150
            .Left = xRg.Left + (xRg.Width - .Width) / 10
        End With
lab:
    Set Pshp = Nothing
    Range("H18").Select
    Next
    Application.ScreenUpdating = True
End If
End Sub

 

[SjonR]

deze na If Target.Address = "$D$1" Then ?

For Each im In Shapes
    If im.Name <> "Picture 27" Then im.Delete
Next

 

[RichieL]

Hoi SjonR,

Bedankt.
Het werkt in zoverre, de pulldown/dropdown werkt na een keer wijzigen niet meer.

 

[SjonR]

Daar had ik even niet op gerekend:

For Each im In Shapes
    If im.Name <> "Picture 27" And TypeName(im.DrawingObject) <> "DropDown" Then im.Delete
Next

 

[RichieL]

Hij werkt.
Alleen nog een vraagje. Waarom "picture 27"?

 

[SjonR]

omdat het logo van google die naam heeft in jouw bestand.

je ziet als je op de afbeelding klikt als het goed is Afbeelding 27 staan linksboven, maar aangezien VBA geen Nederlands verstaat wordt het Picture 27.

 

[HSV]

Geef de nieuwe afbeelding een naam mee zodat je het met die naam ook weer verwijderen kunt.

Geen selectie meer.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$1" Then
 On Error Resume Next
  Set r = Range("H18")
    With ActiveSheet
        .Shapes("Afbeelding_Richiel").Delete
        .Pictures.Insert(r.Value).Name = "Afbeelding_Richiel"
        With .Shapes("Afbeelding_Richiel")
          .Placement = xlMoveAndSize
          .Width = 350
          .Height = 350
          .Top = r.Top
          .Left = r.Left
        End With
   End With
End If
End Sub