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.
' Source code is provide under Creative Commons Attribution License
' This means you must give credit for our original creation in the following form:
' "Includes code created by YOUpresent Ltd. (YOUpresent.co.uk)"
' Commons Deed @ http://creativecommons.org/licenses/by/3.0/
' License Legal @ http://creativecommons.org/licenses/by/3.0/legalcode
'----------------------------------------------------------------------------------
' 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