如何用VBA求面积？

yicol

帮忙，，
在用CAD命令求面积时太麻烦，能不能这样，我在一个封闭的区域内单击鼠标，
让电脑算出该封闭的区域的面积。

myfreemind

编程申请里面有原代码!

bluelover

2楼的能不能说得详细一点儿?
我对这个也比较关心,想借鉴一下,谢了

myfreemind

你们去看看就知道了!不过我的程序你们可能需要改一下,因为是涉及比例尺的!

yicol

大虾，我在编程申请里下载了源代码，但不行呀，老是提示说比例尺不对，不知何故，
我对代码看得不是很懂呀

myfreemind

把userr1参数改为1000，就是设置图纸比例为1000，设为500就是500比例，如果你算的是实地面积用1000比例尺的就可以了！

yicol

刚才我试了一下，那个程序很有帮助，但对我还是不够实用，
我是想像填充一下可以点击，然后可以判断出一个封闭区域，
再来计算这个封闭区域的面积，当然这个区域不一定要是多段线组成，
是直线也应该能行呀，大家帮忙呀

myfreemind

如果不封闭的话可能比较麻烦！

yicol

如果封闭的话怎么写代码呢
能不能说一点建议？

efan2000

呵呵，这个也可以求面积。在封闭区域内选择一点，然后生成它的边界，这个边界就是封闭的多段线，直接使用它的属性就行了。

2. 
   
3. Sub test()
   
4.    
   
5.     ' 当前图纸的实体数目
   
6.     Dim n As Long
   
7.     n = ThisDrawing.ModelSpace.Count
   
8.    
   
9.     ' 调用BOUNDARY命令获取某一点处的边界
   
10.     Dim Pt As Variant
    
11.     Pt = ThisDrawing.Utility.GetPoint(, "指定内部点: ")
    
12.     ThisDrawing.SendCommand "_-Boundary" & vbCr & Pt(0) & "," & Pt(1) & vbCr & vbCr
    
13.    
    
14.     ' 如果存在边界，则会生成新的实体
    
15.     Dim lwpLineObj As AcadLWPolyline
    
16.     If ThisDrawing.ModelSpace.Count > n Then
    
17.         Set lwpLineObj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
    
18.         MsgBox lwpLineObj.Area
    
19.         lwpLineObj.Delete
    
20.     Else
    
21.         MsgBox "未发现有效的边界。"
    
22.     End If
    
23. End Sub
    

<br /> Sub test()<br />     <br />     ' 当前图纸的实体数目<br />     Dim n As Long<br />     n = ThisDrawing.ModelSpace.Count<br />     <br />     ' 调用BOUNDARY命令获取某一点处的边界<br />     Dim Pt As Variant<br />     Pt = ThisDrawing.Utility.GetPoint(, "指定内部点: ")<br />     ThisDrawing.SendCommand "_-Boundary" & vbCr & Pt(0) & "," & Pt(1) & vbCr & vbCr<br />     <br />     ' 如果存在边界，则会生成新的实体<br />     Dim lwpLineObj As AcadLWPolyline<br />     If ThisDrawing.ModelSpace.Count > n Then<br />         Set lwpLineObj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)<br />         MsgBox lwpLineObj.Area<br />         lwpLineObj.Delete<br />     Else<br />         MsgBox "未发现有效的边界。"<br />     End If<br /> End Sub<br />