+1 952 856 3806
Select Page

Knowing the area of a shape in PowerPoint can be very useful when wanting to visually represent a percentage of that shape.

Let’s say we have a map of a country represented by a vector shape in PowerPoint, Excel or Word and we want to visualise that half of that country is occupied by farm land. How could we do that?

We all know how to calculate the area of a square and numerous other geometric shapes but what about an irregular [polygon] shape in PowerPoint? Not so easy. Not in the slightest as you can imagine with this shape! The VBA macro below solves this problem by examining all of the vertices (X/Y points) in the shape and calculating the area based on an unsightly mathematical formula which we won’t bore you with here.

There are a couple of caveats to note if you use this macro:

1. Nodes around the perimeter of a shape in Microsoft Office applications don’t always refer to the real points that make up the outline path. Depending on the type of point, the node may refer to a point on the path or one of two control handles for the point that define a Bezier curve. The macro will check that all segments in the path are straight lines (as per the definition of a polygon) and will convert any curves it finds to straight segments to eliminate any control nodes. This conversion may affect the overall shape and hence its area.
2. The shape must be a freeform shape. The macro can’t and won’t calculate the area of auto shapes such as squares and circles as these are a special type of shapes in PowerPoint (you can of course use the Merge tool in Office 2010 and onwards to convert the shape to a freeform by overlaying another shape above it and using the Intersect mode).
3. The shape must be closed. If it’s not, just right click on it, select Edit Points and then right click on the path before finally selecting Close Path.

## Result

Make sure a single closed freeform shape is selected before your run the macro. When you run it, a text box is added to the top left of the slide with the shape area. You’re then asked if you want to add a square to the slide equal to a given percentage of the area of the shape. This is the result for our US map after requesting a square equal to 50% of the area: ## Using The Macro

If you’ve never used a VBA macro in PowerPoint before, check out our short tutorial which explains how to insert a macro in PowerPoint for the PC or Mac.

Note: we’ve commented out the following line in the main GetShapeArea procedure because for shapes with many hundreds of points, changing the segment type takes a long time and makes it appear as if PowerPoint has crashed (which it hasn’t).

ShapeSegmentsToLine oShp

If you experience any issues with relatively simple shapes (tens of points), then uncomment this line (delete the apostrophe).

## The Macro

This macro is provided under the Creative Commons attribution licence. That means you’re free to use it and modify it and all we ask in return is that you credit us with the original creation as described in the code.

```' VBA Macro to calculate the area of the selected irregular polygon shape
'----------------------------------------------------------------------------------
' Copyright (c) 2014 YOUpresent Ltd.
' This means you must give credit for our original creation in the following form:
' "Includes code created by YOUpresent Ltd. (YOUpresent.co.uk)"
'----------------------------------------------------------------------------------
' Purpose : Calculates the are of the selected shape and optionally adds a square
'           of the same area or a user-selected percentage of it.
'
' Author : Jamie Garroch
' Date : 08SEP2014
' Website : http://youpresent.co.uk and http://www.gmark.co
'----------------------------------------------------------------------------------

Option Explicit

' Main macro procedure
Public Sub GetShapeArea()
Dim oShp As Shape
Dim vertices As Integer
Dim myNode As Integer
Dim oSld As Slide
Dim coords() As Single
Dim myVertices() As Single
Dim myArea As Single, AreaIN As Single, AreaCM As Single
Dim response

' Check that a single shape is selected
If ActiveWindow.Selection.Type = ppSelectionShapes Then
If ActiveWindow.Selection.ShapeRange.Count = 1 Then
Set oShp = ActiveWindow.Selection.ShapeRange(1)
Else
MsgBox "Please select a single shape.", vbCritical + vbOKOnly, "Multiple shapes selected": Exit Sub
End If
Else
MsgBox "Please select a shape.", vbCritical + vbOKOnly, "No shape selected": Exit Sub
End If

' Check that the selected shape is a freeform
If Not oShp.Type = msoFreeform Then MsgBox "Please select a freeform shape.", vbCritical + vbOKOnly, "Selected shape is not a freeform shape": Exit Sub

' Change segments to lines so that Bezier adjustment control nodes are ignored in the path
'ShapeSegmentsToLine oShp

' Check that the selected shape is closed
If Not ShapeIsClosed(oShp) Then MsgBox "Please select a closed shape.", vbCritical + vbOKOnly, "Selected shape is not closed": Exit Sub

Set oSld = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideIndex)

myVertices = oShp.vertices

myArea = CalculateArea(myVertices)

AreaIN = Round(myArea / (72 ^ 2), 2)
AreaCM = Round(myArea / (72 ^ 2 / 2.54 ^ 2), 2)
With oSld.Shapes
Set oShp = .AddTextbox(msoTextOrientationHorizontal, 0, 0, 0, 0)
With oShp
.TextFrame2.TextRange.Text = "Shape Area" & vbCrLf & _
AreaIN & " in2 (a square with sides " & Round(Sqr(AreaIN), 2) & Chr(34) & ")" & vbCrLf & _
AreaCM & " cm2 (a square with sides " & Round(Sqr(AreaCM), 2) & "cm)"
.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
.TextFrame2.WordWrap = msoFalse
End With
End With

response = MsgBox("Would you like to add a square shape representing a percentage of this area to your slide?", vbQuestion + vbYesNo, "Add Square?")
If response = vbYes Then
response = Val(InputBox("What percentage of the total area would you like?", "Enter percentage of area", "100%"))
If IsNumeric(response) Then oSld.Shapes.AddShape msoShapeRectangle, 0, 0, CSng(Sqr(myArea * response / 100)), CSng(Sqr(myArea * response / 100))
End If
End Sub

' Convert curved segments to straight segments to eliminate non path nodes
Private Function ShapeSegmentsToLine(oShp As Shape) As Single
Dim NodeIndex As Integer
On Error Resume Next
If Not oShp.Type = msoFreeform Then Exit Function
With oShp
For NodeIndex = .Nodes.Count To 1 Step -1
If .Nodes(NodeIndex).SegmentType = msoSegmentCurve Then
.Nodes.SetSegmentType NodeIndex, msoSegmentLine
ShapeSegmentsToLine = ShapeSegmentsToLine + 1
End If
Next
End With
End Function

' Check to see if the referenced shape has a closed path
Private Function ShapeIsClosed(oShp As Shape) As Boolean
Dim FirstPoint() As Single, LastPoint() As Single
Dim myVertices() As Single

' Save all of the vertices from the shape to an array
myVertices = oShp.vertices

' Check the the first node's coordinates are the same as the last node e.g. closed path
FirstPoint = oShp.Nodes(1).Points
LastPoint = oShp.Nodes(oShp.Nodes.Count).Points
If FirstPoint(1, 1) = LastPoint(1, 1) And FirstPoint(1, 2) = LastPoint(1, 2) Then ShapeIsClosed = True
End Function

' Algorithm to calculate the area of an irregular polygon using its vertices
Private Function CalculateArea(ByRef myVertices() As Single)
Dim counter As Integer
Dim mySum1 As Long, mySum2 As Long
For counter = LBound(myVertices) To UBound(myVertices) - 1
mySum1 = mySum1 + (myVertices(counter, 1) * myVertices(counter + 1, 2))
mySum2 = mySum2 + (myVertices(counter + 1, 1) * myVertices(counter, 2))
Next
CalculateArea = Abs(mySum1 - mySum2) / 2
End Function
```