Over at Bacon Bits, Mike Alexander has a nice post out yesterday on editing shape points to create custom graphics. It shows how to use a shape’s Edit Points command to create interesting dashboard icons. I haven’t used Edit Points for years, but his post inspired me to fool around with them. I ended up with a bit of code for Editing Shape Points for No Good Reason.
In Mike’s post he shows how you can edit points to modify a half-circle into a more interesting shape. His edit of a half-circle looks something like this (only better):
I thought that was pretty cool, so then I dragged the top below the bottom:
That was fun. Now how about some facial reconstruction for Smiley?
At this point of course I had to learn how to program these edits in VBA. The result is code that randomly messes with the edit points, along with colors:
Pointless Point Editing Code
Dim shp As Shape
Dim shpNodes As ShapeNodes
Dim CenterX As Long
Dim CenterY As Long
Dim CurrXValue As Long
Dim CurrYValue As Long
Dim ws As Excel.Worksheet
Dim pointsArray As Variant
Const PointOffset As Long = 200
Set ws = ActiveSheet
If ws.Shapes.Count = 0 Then
ws.Shapes.AddShape msoShapeSmileyFace, 300, 300, PointOffset, PointOffset
Exit Sub
End If
Set shp = ws.Shapes(1)
CenterX = shp.Left + (shp.Width / 2)
CenterY = shp.Top + (shp.Height / 2)
Set shpNodes = shp.Nodes
With shpNodes
.Insert WorksheetFunction.RandBetween(1, .Count), msoSegmentCurve, msoEditingAuto, _
WorksheetFunction.RandBetween(CenterX - PointOffset, CenterX + PointOffset), _
WorksheetFunction.RandBetween(CenterY - PointOffset, CenterY + PointOffset), _
WorksheetFunction.RandBetween(CenterX - PointOffset, CenterX + PointOffset), _
WorksheetFunction.RandBetween(CenterY - PointOffset, CenterY + PointOffset), _
WorksheetFunction.RandBetween(CenterX - PointOffset, CenterX + PointOffset), _
WorksheetFunction.RandBetween(CenterY - PointOffset, CenterY + PointOffset)
If Timer Mod 2 = 0 Then
pointsArray = .Item(WorksheetFunction.RandBetween(1, .Count)).Points
CurrXValue = pointsArray(1, 1)
CurrYValue = pointsArray(1, 2)
.SetPosition WorksheetFunction.RandBetween(1, .Count), _
CurrXValue + WorksheetFunction.RandBetween(-PointOffset, PointOffset), _
CurrYValue + WorksheetFunction.RandBetween(-PointOffset, PointOffset)
shp.Fill.ForeColor.RGB = WorksheetFunction.RandBetween(1, 10000000)
shp.Line.ForeColor.RGB = WorksheetFunction.RandBetween(1, 10000000)
End If
If Timer Mod 5 = 0 Then
.Delete WorksheetFunction.RandBetween(1, .Count)
End If
End With
End Sub
Every time you run the code above it adds, deletes and/or modifies another point. After a couple of times you get what I like to call “Picasso Smiley”:
A few more and Smiley is getting blown into the next dimension:
Hopefully the code above is pretty straightforward. It leaves a few of the settings unrandomized, chiefly whether the new node is straight, shaped or a corner.
One question. How to refresh Excel between shape format changes?
One version of this code had a loop that edited the points every half second. But try as I might I couldn’t get the screen to update and show those changes. The changes would only appear after the code was finished, making a loop pointless. If anybody knows how to do this, please let us know (thereby adding some useful content to this post).
Download
Here’s a workbook with the the code and a couple of buttons to run it.
The best I’ve been able to do is to end the code with an OnTime for a second later that calls itself. That’s enough to get it to repaint.
did you try doevents, or sleep sandwiched between doevents?
Hi Charlie. Yes. I tried DoEvents, along with toggling visibility of the shape and other items and even toggled ScreenUpdating. I stopped short of OnTime, since I figured Dick would try it :-). I don’t know if there’s a way to call OnTime in less than a second. I’d like to be able to refresh the shape a couple of times a second.
I just spent an hour with your code creating dynamic abstract art. Fun!
Hi , Doug Glancy !
i want to move a node/points (not delete, not insert) of shape already put in spreadsheet Excel using VBA,
You have to be using vba
and so transform a rectangle into a triangle (it remains triangle type) using VBA moving one node of shape
Excel only allows you to move nodes of freeforms , not nodes of shapes.
you know how to convert shapes to freforms using VBA ?
or put the shape in editing mode nodes, like click with the right button of mouse no shape?
like click on toolbar and click edit points ?
iam not find one way on the entire web!
thanks!
Flavio Henrique
Hi Flavio, I can turn a rectangle into a triangle by deleting one of the edit points. I don’t know that you can change a shape’s type to freeform.
I suggest turning on the macro recorder, deleting a point from a rectangle and then examining the code. If that doesn’t address your question, please consider asking on Stack Overflow or other forum. Please let us know if you get an answer. Good luck!
Hi, Doug!
yes, delete one point works, but I need to know to find the position the coordinates of each node (point) in relation to the left corner of the worksheet and in relation to other left node, the size of the shape, to know how many points of distance i will put the node to move to where I want
I can send to your email my samples workbooks.
thank you very mutch!
– Flavio Henrique.
– flaviohenrique2002@hotmail.com
—————————————-
VBA CODES
——————————————————————
Sub DeleteNodesConvertRectangleToTriangle()
ActiveSheet.Shapes.Range(Array(“rectangle1”)).Select
Selection.ShapeRange.Nodes.Delete 3
End Sub
——————————————————————
Sub ShapeNodesConvertTriangleToRetangle()
ActiveSheet.Shapes.Range(Array(“triangle1”)).Select
Selection.ShapeRange.Nodes.Insert 2, msoSegmentLine, msoEditingAuto, 95, 63
End Sub
——————————————————————
FROM MICROSOFT WEBSITE
‘With ActiveSheet.Shapes(1).Nodes
‘pointsArray = .Item(2).Points
‘currXvalue = pointsArray(1, 1)
‘currYvalue = pointsArray(1, 2)
‘.SetPosition 2, currXvalue + 200, currYvalue + 300
‘End With
i dont know the sintax to use “pointsArray” with shapes, only works with freeform!
but maybe have a way !