VBA: Readout Textbox with Shape.OnClick Event

[MeySo]

Hi,

I'm actually trying to refine our duty schedule which was a real mess when we first started with it.

Currently I'm adding a shape in a defined range within the worksheet using the following:

Sub TextBox_Abwesend()
Dim tboAbw As Shape

With Selection
Set tboAbw = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, Selection.Left, Selection.Top, Selection.Width, Selection.Height)

UserForm1.Show
tboAbw.DrawingObject.Text = UserForm1.ComboBox1.Value & vbCrLf & UserForm1.TextBox1.Value & ", " & vbCrLf & Application.UserName & ", " & Date
tboAbw.DrawingObject.Font.Name = "Arial"
tboAbw.DrawingObject.Font.Size = 8
tboAbw.DrawingObject.Font.Bold = False
tboAbw.DrawingObject.Font.Color = RGB(250, 250, 250)
tboAbw.ShapeStyle = msoShapeStylePreset9
tboAbw.TextEffect.Alignment = msoTextEffectAlignmentCentered
tboAbw.Line.Weight = 1
tboAbw.OnAction = "ActiveShape"
Unload UserForm1

End With
End Sub

Now a textbox(shape) is created with several entries within the actual worksheet. Now I'd like to have a simple readout possibility for that textbox which seems a little complicated.
Right now i linked following macro to a command button:

Public Sub ActiveShape()

Dim ActiveShape As Shape
Dim UserSelection As Variant

Set UserSelection = ActiveWindow.Selection
On Error GoTo NoShapeSelected
Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)

On Error Resume Next
MsgBox ActiveShape.TextFrame.Characters.Text, , "Grund"

Exit Sub

NoShapeSelected:
MsgBox "Kein Termin ausgewählt!"

End Sub

Problem with that is clicking the shape doesn't select the shape itself but enables text editing mode instead, so i need to click on the border of the shape again to be able to run that macro.
Therefore I tried to add tboAbw.OnAction = "ActiveShape" in the first macro, but that won't enable the shape selection either and continues with the error handler instead.

Any solutions on how to solve this?

Kind regards,
Daniel

 

[Dan_W]

You could always try using the standard shapes. All the standard shapes (like rectangles, circles, etc) have a text layer that you can do this on. Once you assign a macro to it, it won't enable the text mode.

For example, this is a normal rectangle (not a textbox).

 

[MeySo]

Awesome, I'd never thought of that very simple solution to be honest, I was to stubborn with my idea I assume. Really appreciate your hint!

For those who might be interested:

Public Sub ActiveShape()

Dim ActiveShape As Shape

Set ActiveShape = ActiveSheet.Shapes(Application.Caller)

With New MSForms.DataObject
.SetText Application.Caller
.PutInClipboard
End With

UserForm2.Show

End Sub

Is what I came up with as final solution, it allowed me to implement another smart idea from my coworker -
Instead of the MsgBox I now paste those values in a UserForm which then allows the Readout of those values
as well as a CommandButton to delete that specific entry again.

Thanks again!

 

[Dan_W]

Set ActiveShape = ActiveSheet.Shapes(Application.Caller)

This is a very clever idea! It never occurred to me to use Application.Caller like this.
I think "we're even" now!