Insert/Replace Shape Object - call macro on action

[Marty Plante]

I have code that inserts, or deletes and inserts, for a shape and it hyperlinks back to a contents page. (Code creating the contents page is on worksheet, calls this macro)
I have been trying to come up with a similar macro to create, or deleted and re-create, a shape object on all sheets that calls a macro. I have found examples of on.Action events but been unable to get this to call a macro as opposed to trigger hyperlink as this code does.

There is loop-through code in here, delete and replace on all sheets except the contents sheet, and references to the sheet code that recreates the TOC every time, works perfectly, cannot recall who to credit for the original code. I don't need to include any reference to the content sheet as far as I can see, just create a button in the same manner on every sheet when ran, call the macro on clicking the shape, and I'm set. Many hours on Google & YouTube haven't bailed me out of this one. Unfortunately.

Sub Contents_Hyperlinks()
Dim sht As Worksheet
Dim shp As Shape
Dim ContentName As String
Dim ButtonID As String

'Inputs:
  ContentName = "Table of Contents" 'Table of Contents Worksheet Name
  ButtonID = "_ContentButton" 'ID to Track Buttons for deletion
 
'Loop Through Each Worksheet in Workbook
  For Each sht In ActiveWorkbook.Worksheets
 
    If sht.Name <> ContentName Then
     
      'Delete Old Button (if necessary when refreshing)
        For Each shp In sht.Shapes
          If Right(shp.Name, Len(ButtonID)) = ButtonID Then
            shp.Delete
            Exit For
          End If
        Next shp
       
      'Create & Position Shape
        Set shp = sht.Shapes.AddShape(msoShapeRoundedRectangle, _
          200, 4, 100, 20)

      'Format Shape
        shp.Fill.ForeColor.RGB = RGB(91, 155, 213) 'Blue
        shp.Line.Visible = msoFalse
        shp.TextFrame2.TextRange.Font.Size = 10
        shp.TextFrame2.TextRange.Text = ContentName
        shp.TextFrame2.TextRange.Font.Bold = True
        shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) 'White
     
      'Track Shape Name with ID Tag
        shp.Name = shp.Name & ButtonID
     
      'Assign Hyperlink to Shape
        sht.Hyperlinks.Add shp, "", _
          SubAddress:="'" & ContentName & "'!A1"
 
    End If
   
  Next sht
 
End Sub

 

[John_w]

I have been trying to come up with a similar macro to create, or deleted and re-create, a shape object on all sheets that calls a macro. I have found examples of on.Action events but been unable to get this to call a macro as opposed to trigger hyperlink as this code does.

Replace the sht.Hyperlinks.Add line with:

            shp.OnAction = "'ShapeOnAction " & Q(shp.Name) & "," & Q(sht.Name) & "'"

and add this code:

Public Sub ShapeOnAction(shapeName As String, sheetName As String)
    Dim shp As Shape
    Set shp = Sheets(sheetName).Shapes(shapeName)
    MsgBox shp.Name & " " & sheetName
End Sub

Private Function Q(text As String) As String
    Q = Chr(34) & text & Chr(34)
End Function

As an example, the ShapeOnAction routine is called with 2 string arguments.