shape objects, displaying text, extra info??

[IMAFriend]

Okay, I am trying to convert a bunch of data into a bunch of images. I
decided to use rectangles, because.. well, because that's what the data
represents.

Imagine a jigsaw puzzle, (but all just solid rectangles of different
sizes).

So, my code works pretty well. It draws approximately 4000 rectangles
on the screen in various locations, colors, and whatnot. They do not
overlap, and they do not leave any 'white space'.

Is there a way I can assign some text, or other information, to each
rectangle?


Maybe there is someway I can still use that same built-in text block
within the shape, but when I click on a shape, the text goes into the
status bar, or a popup, or a 'callout'?

I think I can figure out how to add the desired text into the shape.
But...

Can anyone offer some direction on how I can take that text out? Based
on a mouseover, or a click, or arrow keys?

TIA,
DougB

 

[Tom Ogilvy]

If you right click on the shape and select assign macro from the popup menu,
the macro will fire when the shape is clicked.

 

[NickHK]

If you right-click on the rectangle, you have an option "Add Text". The
macro recorder produces ;
ActiveSheet.Shapes("Rectangle 2").Select
Selection.Characters.Text = "Some text"

NickHK

 

[Peter T]

What you've got sounds pretty neat. Expanding on both Tom's & Nick's
suggestions -

Sub Test()
Dim obj As Object, s As String

For Each obj In ActiveSheet.DrawingObjects

With obj
With .TopLeftCell
s = .Left & ":" & .Top
End With
s = .Name & vbLf & s & ":" & .Width & ":" & .Height
End With

If TypeName(obj) = "Rectangle" Or TypeName(obj) = "TextBox" Then
obj.Text = s
obj.OnAction = ThisWorkbook.Name & "!myMacro"
End If

Next

End Sub

Sub myMacro()
Dim sCaller As String, sPrompt As String
Dim obj As Object
Dim v

sCaller = Application.Caller
Set obj = ActiveSheet.DrawingObjects(sCaller)

sPrompt = "Replace text" & vbCr & "enter a # for a new line"
v = Application.InputBox(sPrompt, sCaller)

If Len(v) And Not v = False Then
#If VBA6 Then
v = Replace(v, "#", vbLf)
#Else
v = Application.WorksheetFunction.Substitute(v, "#", vbLf)
#End If
obj.Text = v
End If

End Sub

Sub OtherStuff()
ActiveSheet.Rectangles.OnAction = ThisWorkbook.Name & "!myMacro"

ActiveSheet.TextBoxes.Text = "hello" ' assumes already got Texboxes
' or to delete all text .Text = ""

'.Font will fail applying to +70 textboxes in one go
'loop or faster to make arrays of say 50 tb's, apply font to each array
ActiveSheet.TextBoxes.Font.Size = 8
ActiveSheet.TextBoxes.Font.ColorIndex = 5

End Sub

Regards,
Peter T