Sub doCalculateArea()
On Error Resume Next
Dim s As Shape, sr As ShapeRange, s2 As Shape
Dim oldUnit As cdrUnit, newUnit As cdrUnit
Dim strUnit As String, strArea As String
Dim strMessage As String
Dim myOptionUnit, myOptionInfo
ActiveDocument.ReferencePoint = cdrCenter
'=== DEFAULT UNIT
newUnit = cdrMillimeter
strUnit = "mm"
strArea = "²" 'SUBSCRIPT '2'
myOptionUnit = InputBox("Enter Value 0 (mm), 1 (inch), 2 (cm)", "Change Unit:", 0)
myOptionInfo = InputBox("Enter Value 0 (Dialog Box), 1 (Create Text In Object Selected)", "Option for Info Area:", 0)
If myOptionUnit = 1 Then
newUnit = cdrInch
strUnit = "inch"
ElseIf myOptionUnit = 2 Then
newUnit = cdrCentimeter
strUnit = "cm"
End If
'=== CHANGE UNIT
'For Reset to Recent Document Unit
oldUnit = ActiveDocument.Unit
ActiveDocument.Unit = newUnit
Set sr = ActiveSelectionRange
For Each s In sr
'IF NOT BITMAP & NOT CURVES MUST BE CONVERT TO CURVE
If s.Type <> cdrBitmapShape And s.Type <> cdrCurveShape Then s.ConvertToCurves
strMessage = "Name : " & s.Name & vbCrLf & "Area : " & s.Curve.Area & " " & strUnit & strArea & vbCrLf & "Length : " & s.Curve.Length & " " & strUnit & strArea & vbCrLf
' REMOVE ' BEFORE MsgBox If you want to Get Info By Dialog Message
'========= START OPTION INFO
If myOptionInfo = 0 Then
MsgBox "Name : " & s.Name & vbCrLf & "Area : " & s.Curve.Area & " " & strUnit & strArea & vbCrLf & "Length : " & s.Curve.Length & " " & strUnit & strArea & vbCrLf
Else
'========== START CREATE INFO TEXT
If s.Type = cdrCurveShape Then
'CREATE INFO AREA IN ACTIVE LAYER WITH ARTISTIC TEXT
Set s2 = ActiveLayer.CreateArtisticText(0, 0, strMessage, , , , 6)
'ALIGN TEXT INFO AREA TO CURRENT SHAPE
s2.AlignToShape cdrAlignHCenter + cdrAlignVCenter, s
Set s2 = Nothing
End If
'========== END CREATE INFO TEXT
End If
'========= END OPTION INFO
Next s
'RESET TO RECENT DEFAULT UNIT
ActiveDocument.Unit = oldUnit
End Sub
http://www.grafisin.com/2018/06/request-macro-calculate-area-and-length.html