Block Excel shape selection

In Excel, every shape is selectable via click button. This is sometimes a pain when you do not want an specific shape to be ever selected. Assinning an empty macro to the onAction method will help (although it will fail when trying multiselection):

Public Sub sShp_UnselectMe()
End Sub

There is the option to unselect a shape beeing clicked, but I not yet sure how I can implement it…

Public Sub sShp_UnselectMe()
    Dim oShp As Excel.Shape
    Dim oShpRng As Excel.ShapeRange
    Dim oShpGrp As Excel.Shape
    Dim vShpSelection() As Variant
    Dim lgShp As Long
    Dim lgItem As Long
    
    If TypeName(Application.Selection) = "Range" Then
    ' Shape will not be selected until the oShp.OnAction had run,
    ' so if not prior shape was selected, the selection only comprises range elements
        Exit Sub
    ElseIf TypeName(Application.Selection) = "DrawingObjects" Then
    'composed of: --> "Line" "Arc" "Drawing" "Rectangle" "Oval" "Picture" "TextBox"
        lgItem = -1
        For lgShp = 1 To Application.Selection.ShapeRange.Count
            Set oShp = Application.Selection.ShapeRange.Item(lgShp)
            'If oShp.ID <> g_ShpID Then 'oXlWsh.Shapes(Application.Caller).ID
                lgItem = lgItem + 1
                ReDim Preserve vShpSelection(0 To lgItem)
                vShpSelection(lgItem) = oShp.Name
            'End If
        Next lgShp
        Set oShpRng = ActiveSheet.Shapes.Range(vShpSelection)
        With oShpRng
            .Select
            '.Group
            '.Name = ...
        End With
    
    ElseIf TypeName(Application.Selection) = "GroupObject" Then
        Set oShpGrp = Application.Selection
        'Give name: oShpGrp.Name
    Else
        Exit Sub
    End If
End Sub

But there is a little problem you should solve first. Shape names should be unique so the Application.Caller event does not point to a different shape to the one you’re looking for. This code from StackOverflow will help prevent the issue:

Private Sub TestShpProblem()
    Dim ws As Worksheet
    Dim shp As Shape

    ' reset shapes
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    For Each shp In ws.Shapes
        shp.Delete
    Next shp

    ' add shape
    With ws.Shapes.AddShape(msoShapeRectangle, 10, 10, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape
    With ws.Shapes.AddShape(msoShapeRectangle, 160, 10, 100, 100)
        .Name = "Foo2"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 310, 10, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 10, 160, 100, 100)
        .Name = "Foo2"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 160, 160, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape
    With ws.Shapes.AddShape(msoShapeRectangle, 310, 160, 100, 100)
        .Name = "Foo3"
        .OnAction = "ShapeAction"
    End With

    ' uniqueify shape names - comment out to replicate OP problem
    MakeShapeNamesUnique ws

End Sub

Sub ShapeAction()
    Dim shp As Excel.Shape

    Set shp = Sheet1.Shapes(Application.Caller)
    MsgBox " My name is: " & shp.Name & " and my ID is: " & shp.ID

End Sub

Private Sub MakeShapeNamesUnique(Optional oXlWsh As Excel.Worksheet = Nothing)
    Dim oShp As Excel.Shape
    Dim oDictionay As Object

    Set oDictionay = CreateObject("Scripting.Dictionary")

    'iterate shapes
    If oXlWsh Is Nothing Then Set oXlWsh = ActiveSheet
    For Each oShp In oXlWsh.Shapes
        With oShp
            ' does shape name exist ?
            If Not oDictionay.Exists(.Name) Then
                ' add name to dictionary if not exists with counter of 0
                oDictionay.Add .Name, 0
            Else
                ' found a duplicate --> increment counter
                oDictionay(.Name) = oDictionay(.Name) + 1
                
                ' rename shape with suffix indicating dupe index
                .Name = .Name & "_" & oDictionay(.Name)
            End If
        End With
    Next oShp

    ' Clean up the dictionary
    Set oDictionay = Nothing
End Sub