Editing Shape Points for No Good Reason

Editing Shape Points for No Good Reason

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):

semicircle to wavy

I thought that was pretty cool, so then I dragged the top below the bottom:

semicircle to wavy

That was fun. Now how about some facial reconstruction for Smiley?

smiley to pointy

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

Sub EditPointMadness()
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”:

smiley picasso

A few more and Smiley is getting blown into the next dimension:

smiley in 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.

smiley edit points

8 thoughts on “Editing Shape Points for No Good Reason

    • 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.

  1. 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

  2. i dont know the sintax to use “pointsArray” with shapes, only works with freeform!
    but maybe have a way !

Speak Your Mind

Your email address will not be published. Required fields are marked *

To post code, do this: <code> your vba here </code>