Resizeable Rectangle

[Bill Bell]

I am looking at doing a simple application that allows the user to do
some simple floorplanning of some rectangles. I developed an addin that
provides an initial estimate of the size of the rectangles. Some
rectangles are fixed size and some can vary in x/y dimension but must be
fixed area. I would like to use TextBox shapes but they do not accept
events for the dynamic resizing. I looked at using text box controls
but they cannot be resized by dragging the corners at runtime. Does
anyone know of a control that can be dynamically resized at runtime and
produces events to control the resizing. I would like the user to drag
the sides of the control to size it. I will need to dynamically create
100's of rectangles so it must work with Class modules (WithEvents).

There are other products that can do this but it would very easy for the
user to do this in excel rather than switch to another application.

Regards Bill Bell

 

[Dick Kusleika]

Bill

I don't think such a rectangle exists. Consider this: Using rectangles
from the drawing toolbar, put this in a standard module

Public LastShapeName As String
Public LastShapeHeight As Double
Public LastShapeWidth As Double
Public RecToRec As Boolean
Public TopToBottom As String

Sub ShapeSelect()

'If selection FROM another rectangle then
'fire the selection change event to test
If TypeName(Selection) = "Rectangle" Then
If TopToBottom = "Bottom" Then
Selection.TopLeftCell.Select
TopToBottom = "Top"
Else
Selection.BottomRightCell.Select
TopToBottom = "Bottom"
End If
End If

'If tested OK, store the new information
'and select the rectangle for resizing
If Not RecToRec Then
With Sheet1.Shapes(Application.Caller)
LastShapeName = .Name
LastShapeHeight = .Height
LastShapeWidth = .Width
.Select
End With
RecToRec = False
End If

End Sub

And put this in the sheet's module

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Len(LastShapeName) > 0 Then
With Me.Shapes(LastShapeName)
If .Height <> LastShapeHeight Or .Width <> LastShapeWidth Then
If .Height * .Width > 21816 Then
MsgBox "Area too big"
RecToRec = True
.Select
Else
RecToRec = False
End If
End If
End With
End If

End Sub

Now as you create shapes, assign the ShapeSelect macro to it. It will run
when a user clicks the shape and store the old height and width. It will
then select the shape so the user can resize it.

The selection change event then tests to see if the height or width have
changed, and in this particular example, makes sure the area of the
rectangle is within a certain limit. The RecToRec variable is used to
control when a user selects a rectangle from a different rectangle as
opposed to a cell.