[CAD/VBA]计算选定区域面积

   首先得声明一下：这段代码基本上是"借"来的。只是做了些修改。这段代码的作用是计算选定区域的面积，运行效果如下面的图，用了比较多的SendCommand，不太可取，不过也无大碍，管用就行。另外，有多次对Auto-CAD环境变量的操作，GetVariable/SetVariable，至于各环境变量有什么用，可以查看CAD帮助文档。
         修正Bug：重设ObjectSnapMode之后，原来的捕捉设置会丢失，必须得修改OSMODE环境变量的值才行。

[程序代码]   

Public Sub XArea() '选择一点，计算围绕该点的对象围成的面积
On Error GoTo ErrorHandler
Dim pt As Variant
Dim spt As String
Dim i As Integer
Dim zarea As Double
zarea = 0
    
'得到当前的对象总数
Dim oCount As Long
oCount = ThisDrawing.ModelSpace.count
  
'得到当前边界创建的对象类型(0 为面域，1 为多段线)
Dim oOL As Integer
oOL = ThisDrawing.GetVariable("HPBOUND")
    
'得到当前层的名字
Dim currentLayer As String
currentLayer = ThisDrawing.ActiveLayer.Name
  
'得到当前线体的颜色
Dim oColor As String
oColor = ThisDrawing.GetVariable("CECOLOR")
         '－－By :忽又一天 Email:wzw.icy@gmail.com QQ：365052003
'新建一层并把它设为当前层、还原用户配置
Dim areaLayer As AcadLayer
Set areaLayer = ThisDrawing.Layers.Add("macula_Area_")
areaLayer.color = 11
ThisDrawing.ActiveLayer = areaLayer
  
'关闭对象捕捉
Dim CurSnapMode
CurSnapMode = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.ObjectSnapMode = False
  
'设置新的线体颜色(这一段可以省去提示用户输入，没太大意义，不过类似的写法还是有意义的)
Dim cr As String
cr = ThisDrawing.Utility.GetString(0, vbCrLf & " 选择颜色[随层(L)/随块(K)/自定义(S)]<随层>：")
If cr = "k" Or cr = "K" Then
    ThisDrawing.SetVariable "CECOLOR", "0"
ElseIf cr = "s" Or cr = "S" Then
    ThisDrawing.SendCommand "COLOR "
Else
    ThisDrawing.SetVariable "CECOLOR", "256"
End If
  
Dim oName As String
Dim oLayer As String
Dim oNum As Long
  
'计算单个区域的面积并求和
Do While 1
   pt = ThisDrawing.Utility.GetPoint(, vbCrLf & "请选取区域内部任意一点：")
   spt = pt(0) & "," & pt(1)
  
   With ThisDrawing
     '得到新的对象总数，用于分析是否建立了面域或多段线
     oNum = ModelSpace.count
    
     '设置当前边界创建的对象为面域
     ThisDrawing.SetVariable "HPBOUND", 0
    
     '建立一个面域
     SendCommand Chr(3) & Chr(3) & "-boundary " & spt & " " & " "
    
     '如果建立面域不成功则建立多段线
     If oNum = ModelSpace.count Then
       ThisDrawing.SetVariable "HPBOUND", 1
       SendCommand Chr(3) & Chr(3) & "-boundary " & spt & " " & " "
     End If
    
     '得到最后一个对象的名字
     oName = ModelSpace.Item(ModelSpace.count - 1).ObjectName
    
     '获取把对最后一个对象所在的层，用于分析最后一个对象是否是需要的面域或多段线
     oLayer = ModelSpace.Item(ModelSpace.count - 1).Layer
    
     '由三方面判断对象是否建立，如果建立则计算其面积
     If (oNum < ModelSpace.count) And ((oName = "AcDbRegion") Or (oName = "AcDbPolyline")) And (oLayer = "macula_Area_") Then
       SendCommand "draworder last f "
       SendCommand "area "
       SendCommand "o "
       SendCommand "last "
       zarea = Round(zarea + GetVariable("AREA"), 4)
     End If
   End With
     ThisDrawing.Utility.Prompt vbCrLf & "选定区域的总面积为： " & zarea & vbCrLf
Loop
 ErrorHandler:
'复制结果到剪切板
Set mydataobject = New DataObject
mydataobject.SetText zarea
mydataobject.PutInClipboard
MsgBox "选定区域的总面积为： " & zarea & "   (mm^2)" & Chr(13) & Chr(13) & "计算结果已经复制到剪切板！      ", vbOKOnly, "面积计算"

'删除计算面积产生的对象和图层、还原对象捕捉设置
Do While oCount < ThisDrawing.ModelSpace.count
    ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.count - 1).Delete
Loop
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentLayer)
ThisDrawing.Layers.Item("macula_Area_").Delete
ThisDrawing.SetVariable "CECOLOR", oColor
ThisDrawing.SetVariable "HPBOUND", oOL
ThisDrawing.ObjectSnapMode = True
ThisDrawing.SetVariable "OSMODE", CurSnapMode
SendCommand Chr(3) & Chr(3)
End Sub