XL 2016 (résolu) Supprimer des formes/object en fonction de leur nom

[Hynnuh]

Bonjour à tous,

j'ai une page sur laquelle je dois faire un check des objet et en fonction de leur nom supprimer ceux qui ne peuvent pas rester
deux soucis cependant:
il y a des images, des formes et des commentaires.
pour les images j'ai résolu le problème en les regroupant par un seul nom et en faisant un check du nom je peux "épargner" mon groupe.
en ce qui concerne les commentaire il faut les conserver tous et c'est là que ça ne va plus.
voici le bout de code que j'ai.

For Each DrawingObjects In ActiveSheet.Shapes 'on supprimes toutes les images et formes qui ne sont pas les boutons de la feuille 

If DrawingObjects.Name <> "dudu2" Then DrawingObjects.Delete 'dudu2 est le nom du groupement d'images/formes que je veux conserver

Next

je cherchais la bonne formulation pour avoir quelque chose du genre if drawingobjects.name contient "Comment" then next else ==> voir code précédent.

j'ai essayé le code suivant:

If TypeName(DrawingObjects.OLEFormat.Object) = "Comment" Then next

en repartant d'un code trouvé sur un autre sujet, mais cela ne fonctionne pas et mes commentaires sont supprimés à la fin de l'execution.

cordialement

 

[Dudu2]

Bonjour,
J'avais fait ça y a un bout de temps pour avoir des infos sur les Shapes. Tu dois pouvoir t'en inspirer pour identifier tes Shapes.

'------------------------
'Information sur la Shape
'------------------------
Private Function ShapeInfo(Shp As Shape) As String
    Dim ShapeType As Integer
    Dim Visible As Boolean
    Dim S As String
   
    Static TabShapeType(1 To 32, 1 To 2) As String
    'https://docs.microsoft.com/fr-fr/office/vba/api/office.msoshapetype
    If Len(TabShapeType(30, 1)) = 0 Then
        TabShapeType(30, 1) = "mso3DModel":             TabShapeType(30, 2) = "3D model"
        TabShapeType(1, 1) = "msoAutoShape":            TabShapeType(1, 2) = "AutoShape"
        TabShapeType(2, 1) = "msoCallout":              TabShapeType(2, 2) = "Callout"
        TabShapeType(20, 1) = "msoCanvas":              TabShapeType(20, 2) = "Canvas"
        TabShapeType(3, 1) = "msoChart":                TabShapeType(3, 2) = "Chart"
        TabShapeType(4, 1) = "msoComment":              TabShapeType(4, 2) = "Comment"
        TabShapeType(27, 1) = "msoContentApp":          TabShapeType(27, 2) = "Content Office Add-in"
        TabShapeType(21, 1) = "msoDiagram":             TabShapeType(21, 2) = "Diagram"
        TabShapeType(7, 1) = "msoEmbeddedOLEObject":    TabShapeType(7, 2) = "Embedded OLE object"
        TabShapeType(8, 1) = "msoFormControl":          TabShapeType(8, 2) = "Form control"
        TabShapeType(5, 1) = "msoFreeform":             TabShapeType(5, 2) = "Freeform"
        TabShapeType(28, 1) = "msoGraphic":             TabShapeType(28, 2) = "Graphic"
        TabShapeType(6, 1) = "msoGroup":                TabShapeType(6, 2) = "Group"
        TabShapeType(24, 1) = "msoIgxGraphic":          TabShapeType(24, 2) = "SmartArt graphic"
        TabShapeType(22, 1) = "msoInk":                 TabShapeType(22, 2) = "Ink"
        TabShapeType(23, 1) = "msoInkComment":          TabShapeType(23, 2) = "Ink comment"
        TabShapeType(9, 1) = "msoLine":                 TabShapeType(9, 2) = "Line"
        TabShapeType(31, 1) = "msoLinked3DModel":       TabShapeType(31, 2) = "Linked 3D model"
        TabShapeType(29, 1) = "msoLinkedGraphic":       TabShapeType(29, 2) = "Linked graphic"
        TabShapeType(10, 1) = "msoLinkedOLEObject":     TabShapeType(10, 2) = "Linked OLE object"
        TabShapeType(11, 1) = "msoLinkedPicture":       TabShapeType(11, 2) = "Linked picture"
        TabShapeType(16, 1) = "msoMedia":               TabShapeType(16, 2) = "Media"
        TabShapeType(12, 1) = "msoOLEControlObject":    TabShapeType(12, 2) = "OLE control object"
        TabShapeType(13, 1) = "msoPicture":             TabShapeType(13, 2) = "Picture"
        TabShapeType(14, 1) = "msoPlaceholder":         TabShapeType(14, 2) = "Placeholder"
        TabShapeType(18, 1) = "msoScriptAnchor":        TabShapeType(18, 2) = "Script anchor"
        TabShapeType(32, 1) = "msoShapeTypeMixed":      TabShapeType(32, 2) = "Mixed shape type"  'Value -2 to be changed into 32
        TabShapeType(19, 1) = "msoTable":               TabShapeType(19, 2) = "Table"
        TabShapeType(17, 1) = "msoTextBox":             TabShapeType(17, 2) = "Text box"
        TabShapeType(15, 1) = "msoTextEffect":          TabShapeType(15, 2) = "Text effect"
        TabShapeType(26, 1) = "msoWebVideo":            TabShapeType(26, 2) = "Web video"
    End If
   
    Static TabShapeXlFormControl(0 To 9, 1 To 2) As String
    'https://docs.microsoft.com/fr-fr/office/vba/api/excel.xlformcontrol
    If Len(TabShapeXlFormControl(0, 1)) = 0 Then
        TabShapeXlFormControl(0, 1) = "xlButtonControl": TabShapeXlFormControl(0, 2) = "Button"
        TabShapeXlFormControl(1, 1) = "xlCheckBox":     TabShapeXlFormControl(1, 2) = "Check box"
        TabShapeXlFormControl(2, 1) = "xlDropDown":     TabShapeXlFormControl(2, 2) = "Combo box"
        TabShapeXlFormControl(3, 1) = "xlEditBox":      TabShapeXlFormControl(3, 2) = "Text box"
        TabShapeXlFormControl(4, 1) = "xlGroupBox":     TabShapeXlFormControl(4, 2) = "Group box"
        TabShapeXlFormControl(5, 1) = "xlLabel":        TabShapeXlFormControl(5, 2) = "Label"
        TabShapeXlFormControl(6, 1) = "xlListBox":      TabShapeXlFormControl(6, 2) = "List box"
        TabShapeXlFormControl(7, 1) = "xlOptionButton": TabShapeXlFormControl(7, 2) = "Option button"
        TabShapeXlFormControl(8, 1) = "xlScrollBar":    TabShapeXlFormControl(8, 2) = "Scroll bar"
        TabShapeXlFormControl(9, 1) = "xlSpinner":      TabShapeXlFormControl(9, 2) = "Spinner"
    End If
   
    Select Case Shp.Type
        Case msoOLEControlObject
            Visible = ActiveSheet.OLEObjects(Shp.Name).Visible
            If Not Visible Then ActiveSheet.OLEObjects(Shp.Name).Visible = True
           
        Case Else
            Visible = Shp.Visible
            If Not Visible Then Shp.Visible = True
    End Select
       
    'Correction Type -2
    If Shp.Type = msoShapeTypeMixed Then ShapeType = 32 Else ShapeType = Shp.Type
   
    S = "Caractéristiques de l'objet Shape:" & vbCrLf & vbCrLf & _
        "- Name: """ & Shp.Name & """" & vbCrLf
       
    Select Case Shp.Type
        Case msoOLEControlObject
            On Error Resume Next
            S = S & "- Caption: """ & ActiveSheet.OLEObjects(Shp.Name).Object.Caption & """" & vbCrLf
            If Err.Number > 0 Then S = S & "- Text: """ & ActiveSheet.OLEObjects(Shp.Name).Object.Text & """" & vbCrLf
            On Error GoTo 0
        Case Else
            S = S & "- AlternativeText: """ & Shp.AlternativeText & """" & vbCrLf
    End Select
   
    S = S & _
        "- ID: " & Shp.ID & vbCrLf & _
        "- Type: " & TabShapeType(ShapeType, 1) & " (" & TabShapeType(ShapeType, 2) & ")" & vbCrLf & _
        "- Left: " & Shp.Left & vbCrLf & _
        "- Top: " & Shp.Top & vbCrLf & _
        "- Height: " & Shp.Height & vbCrLf & _
        "- Width: " & Shp.Width & vbCrLf

    Select Case Shp.Type
        Case msoFormControl
            S = S & "- FormControlType: " & TabShapeXlFormControl(Shp.FormControlType, 1) & " (" & TabShapeXlFormControl(Shp.FormControlType, 2) & ")" & vbCrLf
        Case msoOLEControlObject
            S = S & "- TypeName: " & TypeName(ActiveSheet.OLEObjects(Shp.Name).Object)
    End Select
   
    'Return value
    ShapeInfo = S
End Function

Je te mets aussi le classeur d'où ce code est extrait qui permet par simple Mouse Over d'afficher les caractéristiques d'une Shape.

 

[job75]

Bonjour Hynnuh, Dudu2,

Normalement on ne s'amuse pas à modifier les noms des commentaires donc :

Dim s As Shape
For Each s In ActiveSheet.Shapes
    If Left(s.Name, 7) <> "Comment" Then s.Delete
Next

A+

 

[Hynnuh]

Bonjour,
et bien finalement je voulais faire plus complexe que prévu,
en faisant un tri sur le début de nom uniquement et en prenant en compte tous les objects de la page,
j'ai pu faire mon tri sans soucis.

Impeccable merci