Cad vba根据多边形坐标计算多边形面积

在二维平面上，给定两个点 P1​(x1​,y1​) 和 P2​(x2​,y2​)，表达式 (x1​×y2​−x2​×y1​) 代表的数学意义是这两个点与原点 O(0,0) 构成的两个向量 OP1​​ 和 OP2​​ 之间的有向面积的两倍。

具体来说，向量 OP1​​ 的坐标是 (x1​,y1​)，向量 OP2​​ 的坐标是 (x2​,y2​)。这两个向量围成的平行四边形的面积（以原点为顶点）可以通过行列式 ∣​x1​x2​​y1​y2​​​∣ 来计算，即 ∣x1​y2​−x2​y1​∣。但这里我们得到的是有向面积的两倍，即 2×有向面积。

有向面积的概念是指，面积有正负之分，这取决于两个向量的相对方向。如果 OP1​​ 逆时针旋转到 OP2​​（在不超过 180∘ 的情况下），则面积为正；如果顺时针旋转，则面积为负。

然而，在大多数多边形面积计算中，我们关注的是面积的绝对值，因此通常会取 ∣x1​y2​−x2​y1​∣ 的一半作为两个相邻顶点与原点构成的三角形面积，然后将所有这样的三角形面积相加（注意处理正负号以考虑多边形的方向性），从而得到多边形的总面积。但在你的原始问题中，直接给出了 (x1​×y2​−x2​×y1​)，它表示的是有向面积的两倍。

Function CalculateCentroidAndArea(pline As AcadLWPolyline) As Variant  
    ' 定义一个函数，接收一个AcadLWPolyline对象作为参数，返回一个包含质心坐标和面积的数组  
  
    Dim i As Integer  
    ' 循环变量  
  
    Dim xSum As Double, ySum As Double  
    ' 分别用于累加计算质心x坐标和y坐标的权重和  
  
    Dim x1 As Double, y1 As Double  
    Dim x2 As Double, y2 As Double  
    ' 分别用于存储当前点和下一个点的坐标  
  
    Dim A As Double ' 用于计算当前线段与下一个线段形成的三角形的有向面积  
    Dim Cx As Double, Cy As Double ' 用于存储质心的x和y坐标  
    Dim n As Integer  
    ' 闭合多段线的顶点数量的一半（因为每个点由x和y两个坐标组成）  
  
    Dim areaSum As Double  
    ' 累积所有线段形成的多边形面积  
  
    ' 计算顶点数量的一半（因为多段线坐标是成对出现的）  
    n = (UBound(pline.Coordinates) + 1) / 2  
  
    xSum = 0  
    ySum = 0  
    areaSum = 0  
    ' 初始化累加器  
  
    For i = 0 To n - 1  
        ' 遍历所有线段（除了最后一个点和第一个点之间的“虚拟”线段）  
        x1 = pline.Coordinates(2 * i)  
        y1 = pline.Coordinates(2 * i + 1)  
        ' 获取当前点的坐标  
  
        If i = n - 1 Then  
            ' 如果是最后一个点，则与第一个点相连形成闭合图形  
            x2 = pline.Coordinates(0)  
            y2 = pline.Coordinates(1)  
        Else  
            x2 = pline.Coordinates(2 * (i + 1))  
            y2 = pline.Coordinates(2 * (i + 1) + 1)  
            ' 获取下一个点的坐标  
        End If  
  
        ' 计算当前线段与下一个线段（或第一个点）之间的有向面积  
        A = (x1 * y2 - x2 * y1)  
  
        ' 累加有向面积到总面积  
        areaSum = areaSum + A  
  
        ' 累加加权坐标到xSum和ySum，用于后续计算质心  
        xSum = xSum + (x1 + x2) * A  
        ySum = ySum + (y1 + y2) * A  
    Next i  
  
    ' 计算总面积（因为有向面积可能相互抵消，所以取绝对值）  
    ' 但在这里，因为我们是累加所有线段面积，所以直接除以2即可得到多边形面积  
    ' 如果需要处理凹多边形等复杂情况，可能需要额外处理  
    areaSum = areaSum / 2  
  
    ' 计算质心的x和y坐标  
    Cx = xSum / (6 * areaSum)  
    Cy = ySum / (6 * areaSum)  
  
    ' 返回一个包含质心坐标和面积的数组  
    CalculateCentroidAndArea = Array(Cx, Cy, Abs(areaSum))  
End Function

 

Sub MarkAreaOnPolyline()
    Dim pline As AcadLWPolyline
    Dim obj As AcadObject
    Dim centroidArea As Variant
    Dim centroid(0 To 2) As Double
    Dim txt As AcadText
    Dim height As Double
    Dim strArea As String

    ' 提示用户选择一个多段线
    'On Error Resume Next
    ThisDrawing.Utility.GetEntity obj, centroid, "请选择一个闭合多段线: "

    ' 检查选择的对象是否为多段线
    If TypeOf obj Is AcadLWPolyline Then
        Set pline = obj
    Else
        MsgBox "选定的对象不是多段线！"
        Exit Sub
    End If
    
    ' 检查多段线是否闭合
    If Not pline.Closed Then
        MsgBox "请选一个闭合的多段线！"
        Exit Sub
    End If

    ' 计算质心和面积
    centroidArea = CalculateCentroidAndArea(pline)
    
    ' 设置质心坐标
    centroid(0) = centroidArea(0)
    centroid(1) = centroidArea(1)
    centroid(2) = 0 ' Z坐标设为0
    
    ' 设置文字高度
    height = 1

    ' 格式化面积文本
    strArea = "面积: " & Format(centroidArea(2), "0.00") & " 平方单位"

    ' 在质心位置添加文字
    Set txt = ThisDrawing.ModelSpace.AddText(strArea, centroid, height)

    ' 设置文字对齐方式
    txt.Alignment = acAlignmentCenter
    txt.TextAlignmentPoint = centroid

    MsgBox "面积已标注！"
End Sub
'
Function CalculateCentroidAndArea(pline As AcadLWPolyline) As Variant
    Dim i As Integer
    Dim xSum As Double, ySum As Double
    Dim x1 As Double, y1 As Double
    Dim x2 As Double, y2 As Double
    Dim A As Double ' 多段线的面积
    Dim Cx As Double, Cy As Double ' 质心的坐标
    Dim n As Integer
    Dim areaSum As Double
    
    n = (UBound(pline.Coordinates) + 1) / 2
    xSum = 0
    ySum = 0
    areaSum = 0
    
    For i = 0 To n - 1
        x1 = pline.Coordinates(2 * i)
        y1 = pline.Coordinates(2 * i + 1)
        
        If i = n - 1 Then
            x2 = pline.Coordinates(0)
            y2 = pline.Coordinates(1)
        Else
            x2 = pline.Coordinates(2 * (i + 1))
            y2 = pline.Coordinates(2 * (i + 1) + 1)
        End If
        
        A = (x1 * y2 - x2 * y1)
        areaSum = areaSum + A
        xSum = xSum + (x1 + x2) * A
        ySum = ySum + (y1 + y2) * A
    Next i
    
    areaSum = areaSum / 2
    Cx = xSum / (6 * areaSum)
    Cy = ySum / (6 * areaSum)
    
    CalculateCentroidAndArea = Array(Cx, Cy, Abs(areaSum))
End Function

 

Cad 插件定制 ↓↓↓