VBA to determine square footage of selected object using document's current worldscale

While Cadtool 5 is a commercial product, it solves your problem, plus offer other cool features along the way. Each icon along the top opens up many other useful things.

I cobbled the below to do just that. It also employs a user form (I cannot upload the .frx file, but you can easily create one from the doe below.

frmObject area.frm 

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmObjectArea
Caption = "Object Area"
ClientHeight = 2490
ClientLeft = 45
ClientTop = 390
ClientWidth = 4710
OleObjectBlob = "frmObjectArea.frx":0000
StartUpPosition = 1 'CenterOwner
End
Attribute VB_Name = "frmObjectArea"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub cmdCalculate_Click()
Me.tag = "1"
Me.Hide
End Sub

Private Sub cmdCancel_Click()
Me.tag = "0"
Me.Hide
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
End If
End Sub

*********************************

objectArea.csl

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ThisMacroStorage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit

Function buildShapeRange(thisShape As Variant, combinedShape As ShapeRange) As ShapeRange

' this helper function recursively iterates through the selected shape range and and
' adds any valid shapes (e.g., curves, rectangles, ellipses, polygons) to a new shape range
' which is returned to the calling sub

Dim tmpShape As shape

If combinedShape Is Nothing Then 'initialize an empty shape range on first pass
Set combinedShape = New ShapeRange
End If

For Each tmpShape In thisShape.Shapes 'iterate through all shapes
Select Case tmpShape.Type
Case Is = cdrGroupShape 'if this is a group, recursively iterate through all shapes in the group
Set combinedShape = buildShapeRange(tmpShape, combinedShape)
Case Is = cdrRectangleShape, cdrCurveShape, cdrEllipseShape, cdrPolygonShape 'add any valid shape to the combined shape range
combinedShape.Add tmpShape
Case Else 'ignore all other shape types
End Select
Next

Set buildShapeRange = combinedShape 'return combined shape range

End Function

Sub ObjectArea()

' this subroutine calculates the area of a selected object by creating a temporary
' boundary around the selected shapes and using the shape.DisplayCurve.area property
' to determine the area
' since the selection may contain more than one shape, a group or groups, or shapes
' that should not be used in the area computation such as text or dimensions, the
' buildShapeRange helper function is used to create a shape range containing only
' valid shapes

Const title = "Object Area"

Dim thisSelection As ShapeRange 'the shape range of the user's selection
Dim combinedShape As ShapeRange 'a shape range containing the valid shapes
Dim area As Single ' the computed are in world coordinates
Dim boundry As shape ' the temporary boundary created for the computation
Dim oldUnit As Long ' documents original unit scale
Dim label ' used to iterate through the combo box labels
Dim wd As Single ' the document world scale
Dim metrics ' array of unit constants
Dim labels ' array of combo box labels
Dim index As Long 'the index of the combo box selection
Dim tag As String ' the tag set by the dialog indicating calculate or cancel

wd = ActiveDocument.WorldScale ' get the document world scale
oldUnit = ActiveDocument.Unit ' save the documents original units

If ActiveSelectionRange.Shapes.Count = 0 Then 'check to make sure at least one shape is selected
MsgBox "No shape(s) selected. Please select at least one shape and try again", vbCritical, title
GoTo errorExit
End If

metrics = Array(cdrCentimeter, cdrInch, cdrFoot, cdrYard, cdrMeter, cdrMile, cdrKilometer) 'initialize metrics array
labels = Array(" sq centimeters", " sq inches", " sq feet", " sq yards", " sq meters", " sq miles", " sq kilometers") 'initialize label array

For Each label In labels 'iterate through labels to populate the combo box
frmObjectArea.cboMetric.AddItem (Trim(label))
Next

frmObjectArea.Show ' display the dialog box
tag = frmObjectArea.tag ' retrieve the tag set by the cancel ('0') or calculate ('1') button

index = frmObjectArea.cboMetric.ListIndex ' retrieve the index of the combo box selection
Unload frmObjectArea

If (index = -1) Or (tag <> "1") Then GoTo errorExit ' if no combo box item is selected or cancel is pressed exit

ActiveDocument.Unit = metrics(index) ' set units to correspond to the combo box selection

Set thisSelection = ActiveSelectionRange ' get the user's selected shape (s)

Set combinedShape = buildShapeRange(thisSelection, combinedShape) ' call the helper function to return s shape range with only valid shapes

Set boundry = combinedShape.Shapes.All.CreateBoundary(0, 0) ' create a boundary around the shape range

If Not boundry Is Nothing Then 'open shapes will not compute a boundary
area = boundry.DisplayCurve.area
boundry.Delete
End If

If area = 0 Then ' check to make sure a valid area has been returned
MsgBox "Unable to compute area", vbCritical, title
GoTo errorExit
End If

MsgBox Round(wd * wd * area, 2) & labels(index), vbInformation, title ' display a message box with the computed area

errorExit:

ActiveDocument.Unit = oldUnit
Set boundry = Nothing
Set thisSelection = Nothing
Set combinedShape = Nothing

End Sub