Capturing Shape Name/Text from OnAction property

[William Bartusek]

How can I capture (assign) the text content of a shape
(rectangle)into a procedure using the OnAction property
for the shape?
I have many shapes (rectangles) on a worksheet, each of
which is named. When a shape is clicked, I need to assign
the 'Characters.Text' content of that shape to a variable
in the procedure called by the OnAction property. I am
trying to create a usable 'generic' procedure rather than
having a separate procedure for each shape.

 

[Jim Cone]

William,

Do you have a separate procedure for each shape,
or does each shape call the same procedure.

Regards,
Jim Cone
San Francisco, USA

 

[William Bartusek]

I want to create a common procedure that captures the
shape name that is clicked (OnAction), then places
(assigns) the name to a variable in the called procedure.
Right now I have accomplished this by having a separate
procedure for each shape. See comment below.

Private Sub Test()
Dim txt As String, c As Range, rng As Range, rw As Long, r
As Long, ufrm As Object

Worksheets("SERVICE MEASURES-Strategy").Unprotect

Worksheets("SERVICE MEASURES-Strategy").Shapes
("SvcOA_Age").Select 'this is the shape name that
is 'clicked'
'I want the "OnAction" clicked shape "Character.Text" to
be captured in a variable in the called procedure rather
than the pre-coded name "SvcOA_Age" (or whatever the
Character.Text of the shape) so that I don't need a
separate procedure for each shape.

txt = Selection.Characters.Text
'activate the worksheet and named range
Worksheets("STRATEGY GUIDANCE").Activate
Worksheets("STRATEGY GUIDANCE").Range
("STRATEGY_GUID").Activate
rw = Worksheets("STRATEGY GUIDANCE").Range
("STRATEGY_GUID").Rows.Count
'find the Shapes.Text in column 1 of the STRATEGY_GUID
named range
With Worksheets("STRATEGY GUIDANCE").Range
("STRATEGY_GUID").Columns(1)
Set rng = .Find(txt, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, MatchCase:=True)
If Not rng Is Nothing Then
r = rng.Rows.Row

Set ufrm = SvcMeasure
With ufrm
.LblSvcMeasure = Worksheets("STRATEGY GUIDANCE").Range
("B" & r)
.Guidance.Value = Worksheets("STRATEGY GUIDANCE").Range
("C" & r)
.Strategy.Value = Worksheets("STRATEGY GUIDANCE").Range
("D" & r)
.Locate = r
.Show
End With
End If
End With

Worksheets("STRATEGY GUIDANCE").Range("A1").Activate
Worksheets("SERVICE MEASURES-Strategy").Activate
Worksheets("SERVICE MEASURES-Strategy").Protect

End Sub

 

[Jim Cone]

William,

Assign the "DoThemAll" sub to each shape.
'DoThemAll' determines the text in the shape and then
passes that text in a variable to your main procedure (Test)...
'---------------------------------
Sub DoThemAll()
Dim strName As String
Dim strText As String
strName = Application.Caller
strText = ActiveSheet.Shapes(strName).TextFrame.Characters.Text
'Call the main procedure, passing strText to it
Test strText
End Sub

Private Sub Test(ByRef txt As String)
Dim c As Range
Dim rng As Range
Dim rw As Long
Dim r As Long
Dim ufrm As Object

'Your code
MsgBox txt
End Sub
'---------------------------------

Regards,
Jim Cone
San Francisco, USA