OCE 源头代码：AutoCAD VBA 凸多边形面积

如下图中的公式 4-15：已知三角形顶点坐标 Xi, Yi，可以求解其面积。同样道理，将行列式中的 Xi 与 Yi 替换为 X 与 Y 即可求得红色阴影三角形面积。注意：为了避免行列式中的面积出现负值，三角形顶点编码应按逆时针方向编排。

上述做法可以推广到四边形、五边形、六边形等凸多边形的面积计算：假设 M 边形内部的任意一点 J（X, Y），多边形的面积等于 M 个行列式 N.ji, i = 1 to M 之和的一半。另外，按照上面的逆时针编排规则。如果行列式中有某个 N.ji 出现负值，表明点 J 在多边形外；若出现 N.ji = 0 则表明点 J 在多边形的边上。

源代码中包含四个过程及函数：1）面积计算主过程；2）三角形面积计算函数 Area3；3）凸多边形面积计算函数 AreaPoly；4）创建选择集的过程。

Option Explicit

-------------------------------------------------------------------------------------------------------------

Public Sub MainSub()

Dim SeleObjts As AcadSelectionSet

Call CreateSelectionSet(SeleObjts, "SeleObjts")
SeleObjts.SelectOnScreen

Dim Objt As Object
Dim Area As Double

Dim Pc(2) As Double

For Each Objt In SeleObjts
  If TypeOf Objt Is AcadLWPolyline Then
  
    Area = AreaPoly(Objt, Pc(0), Pc(1))
    ThisDrawing.ModelSpace.AddText Str(Area), Pc, 2000

  End If
Next Objt

Set SeleObjts = Nothing

End Sub

-------------------------------------------------------------------------------------------------------------

Sub CreateSelectionSet(SeleObjts As AcadSelectionSet, Name As String)

On Error Resume Next

If Not IsNull(ThisDrawing.SelectionSets.Item(Name)) Then
Set SeleObjts = ThisDrawing.SelectionSets.Item(Name)
SeleObjts.Delete
End If

Set SeleObjts = ThisDrawing.SelectionSets.Add(Name)

End Sub

-------------------------------------------------------------------------------------------------------------

Public Function AreaPoly(Poly As AcadLWPolyline, Xc As Double, Yc As Double) As Double

Dim i As Integer
Dim n As Integer:  n = (UBound(Poly.Coordinates) + 1) / 2

Dim Pc(2) As Double

For i = 1 To n
  Pc(0) = Pc(0) + Poly.Coordinates(2 * i - 2) / n
  Pc(1) = Pc(1) + Poly.Coordinates(2 * i - 1) / n   '取坐标平均值作为点(j)
Next i

Dim Si As Double

For i = 1 To n - 1
  Si = Si + Area3(Pc, Poly.Coordinate(i - 1), Poly.Coordinate(i))
Next i

AreaPoly = Si + Area3(Pc, Poly.Coordinate(n - 1), Poly.Coordinate(0))

Xc = Pc(0)
Yc = Pc(1)  

End Function

-------------------------------------------------------------------------------------------------------------

Public Function Area3(P1 As Variant, P2 As Variant, P3 As Variant) As Double

Dim x1: x1 = P1(0):   Dim y1: y1 = P1(1)
Dim x2: x2 = P2(0):   Dim y2: y2 = P2(1)
Dim x3: x3 = P3(0):   Dim y3: y3 = P3(1)

Dim Sx As Double: Sx = x1 * y2 + x2 * y3 + x3 * y1
Dim Sy As Double: Sy = y1 * x2 + y2 * x3 + y3 * x1

Area3 = 0.5 * (Sx - Sy)

End Function

-------------------------------------------------------------------------------------------------------------

以下是程序运行结果及代码验证过程：采用方法一或方法二，按逆时针及顺时针绘制一个或多个凸多边形，通过属性查看面积并与运行结果比较。注意：1）面积为负值的原因；2）顶点数比边数多的多段线，其运行结果有何不同？