Insert/Replace Shape Object - call macro on action

Marty Plante

New Member
Joined
Dec 28, 2016
Messages
11
Office Version
  1. 365
Platform
  1. Windows
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.

VBA Code:
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
 
Last edited by a moderator:

Some videos you may like

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,723
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:
VBA Code:
            shp.OnAction = "'ShapeOnAction " & Q(shp.Name) & "," & Q(sht.Name) & "'"
and add this code:
VBA 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.
 

Watch MrExcel Video

Forum statistics

Threads
1,128,161
Messages
5,629,050
Members
416,363
Latest member
zaveedd

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top