计算选定区域面积 - 石陆软件屋

首先得声明一下：这段代码基本上是"借"来的。只是做了些修改。这段代码的作用是计算选定区域的面积，运行效果如下面的图，用了比较多的SendCommand，不太可取，不过也无大碍，管用就行。另外，有多次对Auto-CAD环境变量的操作，GetVariable/SetVariable，至于各环境变量有什么用，可以查看CAD帮助文档。
         修正Bug：重设ObjectSnapMode之后，原来的捕捉设置会丢失，必须得修改OSMODE环境变量的值才行。
[程序代码]       －－By :忽又一天 Email:wzw.icy@gmail.com QQ：365052003
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
       '－－By :忽又一天 Email:wzw.icy@gmail.com QQ：365052003
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)

[阅读字体大小: 大中小]

[本日志由 admin 于 2014-04-14 08:32 AM 编辑]

引用通告地址 (0)：
复制引用地址

http://www.cnng.net/blog/trackback.asp?tbID=74
复制引用地址

http://www.cnng.net/blog/trackback.asp?tbID=74&CP=GBK