Http://www.cnng.net  首页 原创软件   VB文挡  VB资源   乱舞人生  资源   Tags  给我留言 
用户登陆
用户:
密码:
 

站点日历
73 2024 - 12 48
1234567
891011121314
15161718192021
22232425262728
293031


站点统计

最新日志
CAD图中所有选中的文字数字的自动求和 详细讲解CAD的字体文件分类
晴天 计算选定区域面积   [ 日期:2014-04-13 ]
首先得声明一下:这段代码基本上是"借"来的。只是做了些修改。这段代码的作用是计算选定区域的面积,运行效果如下面的图,用了比较多的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
暂时没有评论
发表评论 - 不要忘了输入验证码哦!
作者: 用户名:  密码:   注册? 验证码: 
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字
表  情