OCE 源头代码：AutoCAD VBA 剪力墙截面形心

AutoCAD 中的面域可以通过 MassProp 命令查询形心位置及惯性矩。但对于多段线绘制的几何图形，其属性中只有面积及周长，没有形心位置。本文旨在通过代码来解决这个问题。

暂时未找到一般性的算法，于是先从定义出发：将不规则图形分割为多个矩形来处理。例如三个矩形的面积及形心坐标分别为：A1 (X1, Y1) 、A2 (X2, Y2)、A3 (X3, Y3)；则不规则图形 A = A1 + A2 + A3 的形心坐标就是：

Xc = (A1*X1 + A2*X2 + A3*X3) / (A1 + A2 + A3)

Yc = (A1*Y1 + A2*Y2 + A3*Y3) / (A1 + A2 + A3)

下面是 AutoCAD VBA 的代码实现过程。首先是 ThisDrawing 模块的内容：

Option Explicit

Public Sub PolyCenter()

Dim SeleObjts As AcadSelectionSet

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

Dim Objt As Object
Dim nPoly As Integer

Dim Polys() As AcadLWPolyline

For Each Objt In SeleObjts
 
If TypeOf Objt Is AcadLWPolyline Then
  nPoly = nPoly + 1: ReDim Preserve Polys(1 To nPoly): Set Polys(nPoly) = Objt
End If
 
Next Objt

Set SeleObjts = Nothing

'==========================================================================================

Dim P1 As Variant:  Dim b1 As Double:  Dim Xc As Double:  Dim Xc1 As Double
Dim P3 As Variant:  Dim h1 As Double:  Dim Yc As Double:  Dim Yc1 As Double

Dim TotalArea As Double

Dim i As Integer

For i = 1 To nPoly

  Call RectToCorner(Polys(i), P1, P3)
  
  b1 = P3(0) - P1(0):  Xc1 = 0.5 * (P3(0) + P1(0))
  h1 = P3(1) - P1(1):  Yc1 = 0.5 * (P3(1) + P1(1))
  
  TotalArea = TotalArea + (b1 * h1)
  
  Xc = Xc + Xc1 * (b1 * h1)
  Yc = Yc + Yc1 * (b1 * h1)

Next i

If TotalArea = 0 Then MsgBox "矩形顶点个数等于 5 导致面积为零，异常退出！", vbExclamation, "OCE 数据绘图"
If TotalArea = 0 Then Exit Sub

Xc = Xc / TotalArea
Yc = Yc / TotalArea
  
'==========================================================================================

Dim pt(2) As Double

pt(0) = Xc
pt(1) = Yc

Dim Oc As AcadCircle

Set Oc = ThisDrawing.ModelSpace.AddCircle(pt, 200)

End Sub

然后是通用模块代码，涉及两个函数及过程：1、选择集的定义；2、获取轻量多段线左下角点 P1 以及右上角点 P3 的函数。

Option Explicit

Public 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 Sub RectToCorner(Poly As AcadLWPolyline, P1 As Variant, P3 As Variant)

Dim pt1(0 To 2) As Double
Dim pt3(0 To 2) As Double

pt1(0) = Poly.Coordinate(0)(0)
pt1(1) = Poly.Coordinate(0)(1)

pt3(0) = Poly.Coordinate(2)(0)
pt3(1) = Poly.Coordinate(2)(1)

Dim MaxX As Double: Dim MinX As Double
Dim MaxY As Double: Dim MinY As Double

MaxX = pt1(0):  If pt3(0) > pt1(0) Then MaxX = pt3(0)
MinX = pt1(0):  If pt3(0) < pt1(0) Then MinX = pt3(0)

MaxY = pt1(1):  If pt3(1) > pt1(1) Then MaxY = pt3(1)
MinY = pt1(1):  If pt3(1) < pt1(1) Then MinY = pt3(1)

pt1(0) = MinX:  pt3(0) = MaxX
pt1(1) = MinY:  pt3(1) = MaxY

P1 = pt1:  P3 = pt3

End Sub

代码运行时：先选择要计算形心的多个矩形，然后单击鼠标右键即可标记形心位置。注意：手动采用多段线建立的矩形其顶点数量是 5，不符合本程序的要求。要采用 AutoCAD 自带的命令或按钮来创建矩形。以下是程序运行结果及验证过程。