Area of freeform shapes

[Dave Shaw]

I thought someone in the Excel group (original post in Word programming) may
be able to help:

Thanks
___

Thanks for that but my problem is calculating freeform shapes - someone could
draw any shape with straight lines (star, random polygon, etc.) - so the
basic height x width does not work.

The concept to calculate I understand - the shape would need to be broken
down into triangles, the area of each triange calculated and then added
together. I can do this myself with a ruler and protractor - I'm just not
advanced enough at doing this using a macro - I'm rubbish at loops and never
really used VB for calculating angles and have no idea of how to split a
shape into triangles.

Hi Dave,

Sub Test456()
Dim x As Double
Dim y As Double
x = PointsToCentimeters(Selection.ShapeRange(1).Height)
y = PointsToCentimeters(Selection.ShapeRange(1).Width)
MsgBox Format(x * y, "#.00 cm²")
End Sub

--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP

__
Hi

I would like users to be able to draw freeform shapes (using straight not
curved lines) and then to run a macro to calculate it's area in cm. I don't
mind if this is in Word 2003 or Excel 2007.

I have found some links on the web for excel methods but none of them seem
to work - I get overflow errors.

Any ideas

Thanks

 

[Gary''s Student]

See:

http://local.wasp.uwa.edu.au/~pbourke/geometry/polyarea/

 

[Dave Shaw]

Sorry I'm not that clever, how do I use the function in a VB module - I've
copied PolygonArea function but don't know what variable to feed it.

Thanks

 

[Rick Rothstein \(MVP - VB\)]

The following is a posted answer I once gave over in the compiled VB world,
but nothing in the code would preclude it from working within Excel's VBA
environment. Perhaps you can make use of it.

Rick

Back in the old days, before electronic calculators (we used to use an old
Monroe mechanical push button, mechanical crank handle jobber with about a
million gears in it), we used to calculate areas adding and subtracting
trapezoidal areas as we went in order around the nodes of the polygon. Here
is a VB adaptation of that procedure. For simplicity sake and to keep the
function wholly self-contained, I set it to take two arguments -- an array
of X-Coordinates and an array of Y-Coordinates (both of type Double).
Obviously they are linked by their indices -- Xcoord(N) and Ycoord(N) both
referring to the same Nth node on the polygon. The nodes *must* be store in
sequential order, one after the other as you travel either clockwise or
counter-clockwise around the polygon.

'Calculate the gross area of a polygon
'======================================
Function AreaByCoordinates(Xcoord() As Double, _
Ycoord() As Double) As Double
Dim I As Long
Dim Xold As Double
Dim Yold As Double
Dim Yorig As Double
Dim ArrayUpBound As Long
ArrayUpBound = UBound(Xcoord)
Xold = Xcoord(ArrayUpBound)
Yorig = Ycoord(ArrayUpBound)
Yold = 0#
For I = LBound(Xcoord) To ArrayUpBound
X = Xcoord(I)
Y = Ycoord(I) - Yorig
AreaByCoordinates = AreaByCoordinates + _
(Xold - X) * (Yold + Y)
Xold = X
Yold = Y
Next
AreaByCoordinates = Abs(AreaByCoordinates) / 2
End Function

Note: The Yorig is used to normalize all measurements around a common point
within or touching the polygon. The reason -- to minimize any errors that
might be generated by having the nodes "far" away from the (0,0) origin.
This is probably not needed, but since it adds a miniscule amount of
overhead to the time required to calculate the area, I opted to put it in.

 

[Peter T]

Another one -

Sub FreeformArea()
Dim p As Long, nxt As Long
Dim Ar As Single
Dim shp As Shape
Dim nds As ShapeNodes

Set shp = ActiveSheet.Shapes("Freeform 1")
'Set shp = Selection

If shp.Type <> msoFreeform Then
MsgBox "not a Freeform"
Exit Sub
End If

Set nds = shp.Nodes

Ar = 0
For p = 1 To nds.Count
nxt = p + 1
If nxt > nds.Count Then nxt = 1

Ar = Ar + (nds(nxt).points(1, 1) - nds(p).points(1, 1)) _
* (nds(p).points(1, 2) + nds(nxt).points(1, 2))
Next

Ar = Abs(Ar) / 2

MsgBox Ar & " square points"
' 72x72 points per sqr inch

End Sub

Regards,
Peter T

PS, to test Rick's try something like this

Sub test()
Dim nds As ShapeNodes
Dim i As Long
Dim result As Double

Set nds = ActiveSheet.Shapes("Freeform 1").Nodes
ReDim arrX(1 To nds.Count) As Double
ReDim arrY(1 To nds.Count) As Double
For i = 1 To nds.Count
arrX(i) = nds(i).points(1, 1)
arrY(i) = nds(i).points(1, 2)
Next

result = AreaByCoordinates(arrX, arrY)
MsgBox result
End Sub

 

[Dave Shaw]

Rick and Peter

Thanks very much those are great.

Dave

 

[Rick Rothstein \(MVP - VB\)]

Thanks for the code assist showing the OP how to make use of my function. I
have never had to work with shapes before, so your posting has taught me a
little bit of how to work with them as well. Thank you.

Rick

 

[Dave Shaw]

Sorry another question - i have used both methods and they come up with very
similar result. However if I resize the shape the area doesn't change
properly.

to see if I could find the reason I have tried to set the size of a shape
using VB to set the location but when it goes back through the function it
says that the location is different to where the locations are set to. Does
this make any sense?

 

[Rick Rothstein \(MVP - VB\)]

I'm sorry, but I am not following what you are trying to do. You say the
"location is different"... do you mean the coordinates you input and the
coordinates my function is using to calculate its results are not the same?
If so, yes, that is by design. The code was originally designed some 30
years or so ago for BASICA or GWBASIC (one of the original BASIC languages
on a PC) for use in the New Jersey Department of Transportation in the road
design group I worked for at the time. The coordinate system we worked with
had one coordinate in the 2,000,000s and the other in the 600,000s. In order
to reduce the size of the multiplications, I reduced 'translated' (moved)
the figure closer to the the origin along the Y-axis. This does change the
shape, so the calculated area will be the same as for figure in its original
location, but the numbers being derived in the intermediate stages are more
'manageable. Was that what you were referring to?

As to the area not changing properly when the shape is resized... can you
give me a before/after example that demonstrates this problem in my
function?

Rick

 

[Dave Shaw]

Sorry it was a confusing post...

I have a freeform square (3.53cm x3.53cm). I created this by the following
code on a freeform to see what was going wrong:

Set nds = ActiveSheet.Shapes(Selection.Name).Nodes
nds.SetPosition 1, 0, 0
nds.SetPosition 2, 0, 0
nds.SetPosition 3, 0, 100
nds.SetPosition 4, 100, 100
nds.SetPosition 5, 100, 0

So it is located in the top left hand corner of the sheet.

Then I run both codes. They use the following positions for the nodes:

0,0
0,0
0,66.6664581298828
90.6637802124023,0

So in this case it calculates the area as being 6,044 when I know the area
is 100 x 100 = 10,000

If I then scale the square by 200% I end up with an area of 1,511 = 1/2^2

If I just stretch using a mouse or by using the height and with attribute
the area does not change.

However I have just drawn 2 shapes with different areas and it seems to work
- is it something to do with resizing?

Thanks

Dave

 

[Peter T]

So in this case it calculates the area as being 6,044 when I know the area

is 100 x 100 = 10,000

I ran both Rick's & my routines on your code modified freeform of 100x100.
Both returned 9950.06. That's correct as in my system the freeform gets
redrawn to 99.75x99.75. Typically accuracy of shapes is to the nearest 0.75
points.

Anyway, no idea how you get 6,044, are you sure you are processing the
correct shape.

I also tried resizing, with code & manually scaling, I got predicted
results.

Rick - In all tests I get same results with our respective routines to
within 2dp of a square point. In theory your doubles will be more accurate,
but finer than 100th a sqr pnt is beyond the precision to which shapes can
be drawn. Tested 3 to 200+ node freeforms.

Regards,
Peter T

 

[Rick Rothstein \(MVP - VB\)]

I'm not sure why you have 5 nodes in what is obviously a square, but that
shouldn't matter. I'm also not sure what the 3.53cm has to do with the 100
units being used for the coordinates. However, when I run this code...

Sub Test()
Dim X() As Double
Dim Y() As Double
ReDim X(0 To 4)
ReDim Y(0 To 4)
X(0) = 0
Y(0) = 0
X(1) = 0
Y(1) = 0
X(2) = 0
Y(2) = 100
X(3) = 100
Y(3) = 100
X(4) = 100
Y(4) = 0
MsgBox AreaByCoordinates(X, Y)
End Sub

I get a MessageBox displaying 10000, as expected. By the way, for a square,
I would have used this code...

Sub Test()
Dim X() As Double
Dim Y() As Double
ReDim X(0 To 3)
ReDim Y(0 To 3)
X(0) = 0
Y(0) = 0
X(1) = 100
Y(1) = 0
X(2) = 100
Y(2) = 100
X(3) = 0
Y(3) = 100
MsgBox AreaByCoordinates(X, Y)
End Sub

Rick

 

[Rick Rothstein \(MVP - VB\)]

Rick - In all tests I get same results with our respective routines to

within 2dp of a square point. In theory your doubles will be more
accurate,
but finer than 100th a sqr pnt is beyond the precision to which shapes can
be drawn. Tested 3 to 200+ node freeforms.

Remember, the Double I used was because the routine was developed for a
"real world" application... this application was carried out to 5 decimal
places for calculation purposes and eventually rounded to 2 decimal places
for inclusion in the contract set of plans.

Rick

 

[Dave Shaw]

I don't understand nodes - I thought it would be a created point so did think
that a square would have 4. However whenever I draw a freeform shape it has
1 more node than expected so in this case 5.

The 3.53cm is the size excel tells me the square is that is created by using
the co-ordinates - i.e. 100pts = 3.53cm?

The code works fine in terms of calculation I just can't work out why it is
using the co-ordinates it is doing. Not sure if it makes any difference but
I'm using Excel 2007.

 

[Peter T]

"Dave Shaw" wrote

I don't understand nodes - I thought it would be a created point so did think
that a square would have 4. However whenever I draw a freeform shape it has
1 more node than expected so in this case 5.

Hold Ctrl and click on the sheet
still holding ctrl, click another point on same imaginary horizontal line
click two more corners of a square
still holding ctrl move mouse over the point where you started and click
again
you should have drawn a roughly a square with perfect straight sides, it
should have 4 nodes, the last click would have 'enclosed' the freeform. Now
modifiy your code as posted with just the 4 nodes.
(Could also hold Shift to 'snap' to cell-grid whicle drawing)

The 3.53cm is the size excel tells me the square is that is created by using
the co-ordinates - i.e. 100pts = 3.53cm?

Sounds right, 2.54cm/in x 100 / 72pt/in = 3.53

The code works fine in terms of calculation I just can't work out why it is
using the co-ordinates it is doing. Not sure if it makes any difference but
I'm using Excel 2007.

Difficult to know what co-ordinates you have. Try this:

Sub SqrFreeform()
Dim shp As Shape
Dim SZ As Single

SZ = 100

With ActiveSheet.Shapes.BuildFreeform(msoEditingCorner, 0, 0)
.AddNodes msoSegmentLine, msoEditingAuto, SZ, 0
.AddNodes msoSegmentLine, msoEditingAuto, SZ, SZ
.AddNodes msoSegmentLine, msoEditingAuto, 0, SZ
.AddNodes msoSegmentLine, msoEditingAuto, 0, 0
Set shp = .ConvertToShape
End With

Debug.Print shp.Name

Dim nd As ShapeNode
For Each nd In shp.Nodes
Debug.Print nd.Points(1, 1), nd.Points(1, 2)
Next
'0 0
'99.75 0
'99.75 99.75
'0 99.75
End Sub

If you run the area routine you should get predicted 10,000 or probably 9950

Something I hadn't thought of before, if you draw a squiggly enclosed
freeform the area routines will only give an approximate answer. For an
exact result points need to be joined with straght lines. Following should
convert from curves to lines if necessary:

Sub CurvesToLines()
Dim n As Long
' adjust the index or name as required
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Nodes
n = 1
While n <= .Count
If .Item(n).SegmentType = msoSegmentCurve Then
.SetSegmentType n, msoSegmentLine
End If
n = n + 1
Wend
End With
End Sub

Regards,
Peter T

 

[Dave Shaw]

if i run the routine i do get the right result but if I resize it the result
does not change?

Drawing as instructed I still end up with 5 nodes but using the routine I
end up with 4.