[求助]：如何求出一个图层的面积？？

bajie011

本人由于算建筑的面积，所有闭合线条都在同一图层，如果用常规方法的话很麻烦，请教各位大侠有什么高招能够快速算出一个图层的面积！！谢谢！！！

cdhua001

看看这样行吗？

bajie011

这种方法不错，不过我的图层里面有1200多个闭合的图形，如果用这种方法的话是不是太复杂了些？？是不是比你AREA的方法更复杂？

陌生人

你来错地方了。编程板块有不知道多少个这样的程序了。我都记不清了，哈哈。
随手就可以给你写一个

2. 
   
3. (defun c:test (/ ss vss aa pt1 pt2)
   
4.   (vl-load-com)
   
5.   (setq ss  (ssget '((0 . "*polyline")))
   
6.         vss (vla-get-activeselectionset (vla-get-activedocument(vlax-get-acad-object)))
   
7.         aa  0)
   
8.   (vlax-for obj vss
   
9.     (setq pt1 (vlax-curve-getpointatparam obj (vlax-curve-getstartparam obj))
   
10.           pt2 (vlax-curve-getpointatparam obj (vlax-curve-getendparam obj)))
    
11.     (if (equal pt1 pt2)(setq aa (+ aa (vla-get-area obj))))
    
12.   )
    
13.   aa
    
14. )
    

<br /> (defun c:test (/ ss vss aa pt1 pt2)<br />   (vl-load-com)<br />   (setq ss  (ssget '((0 . "*polyline")))<br />         vss (vla-get-activeselectionset (vla-get-activedocument(vlax-get-acad-object)))<br />         aa  0)<br />   (vlax-for obj vss<br />     (setq pt1 (vlax-curve-getpointatparam obj (vlax-curve-getstartparam obj))<br />           pt2 (vlax-curve-getpointatparam obj (vlax-curve-getendparam obj)))<br />     (if (equal pt1 pt2)(setq aa (+ aa (vla-get-area obj))))<br />   )<br />   aa<br /> )<br />

bajie011

楼上的大侠，本人实在愚昧，看不懂这么高深的编程公式，可不可以上传一个外挂程序给小弟，小弟在此不胜感激！！！

talkershadows

把上面的code存为lsp文件，加载就可以～～～

yuguohui337

什么是lisp语言
那为大侠介绍一下

自由的鱼

LISP语言是AUTOCAD二次开发的一种语言，网上有电子教程，你可以下载看看！
下面这是一个VBA代码，功能一样的，你可以看看！

Option Explicit
Sub smarea()
On Error Resume Next
Dim i As Integer
Dim areaobj As AcadLWPolyline
Dim sset As AcadSelectionSet
Dim minpnt As Variant
Dim maxpnt As Variant
Dim areains(0 To 2) As Double
Dim txtarea As String
Dim txtins As String
Dim ms As String
Dim txtobj As AcadText
Dim Ftype As Variant
Dim Fdata As Variant
Dim entity As AcadEntity
Dim hatchobj As AcadHatch
Dim pname As String
Dim pype As Long
Dim outloop(0 To 0) As AcadEntity
Dim zminpnt(0 To 2) As Double
Dim zmaxpnt(0 To 2) As Double
Dim sclayer As String
Dim zarea As Double
zarea = 0


Dim us1 As Integer
ThisDrawing.SetVariable "userr1", 1000
us1 = ThisDrawing.GetVariable("userr1")
sclayer = ThisDrawing.GetVariable("clayer")

If ThisDrawing.SelectionSets.Count > 0 Then
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Clear
ThisDrawing.SelectionSets.Item(i).Delete
Next
End If


Dim gpCode(3) As Integer, dataValue(3) As Variant






gpCode(0) = -4
dataValue(0) = "

gpCode(1) = 0
dataValue(1) = "PolyLINE"


gpCode(2) = 0
dataValue(2) = "LwPolyline"






gpCode(3) = -4
dataValue(3) = "or>"

Ftype = gpCode
Fdata = dataValue







Set sset = ThisDrawing.SelectionSets.Add("smarea1")

sset.Select acSelectionSetAll, , , Ftype, Fdata

For Each entity In sset
If entity.Layer = sclayer Then

entity.GetBoundingBox minpnt, maxpnt

areains(0) = (minpnt(0) + maxpnt(0)) / 2
areains(1) = (minpnt(1) + maxpnt(1)) / 2
areains(2) = 0

zminpnt(0) = minpnt(0) - 250
zminpnt(1) = minpnt(1) - 250
zminpnt(2) = 0
zmaxpnt(0) = maxpnt(0) + 250
zmaxpnt(1) = maxpnt(1) + 250
zmaxpnt(2) = 0


If entity.Closed = False Then

ThisDrawing.Application.ZoomWindow zminpnt, zmaxpnt
entity.Color = acRed
entity.Highlight True
MsgBox "当前视口图形不闭合，请检查！"


Exit Sub
End If




Select Case us1
Case 500
txtarea = entity.Area / 4

Case 1000
txtarea = entity.Area
Case 2000
txtarea = entity.Area * 4
Case Else
MsgBox "你的比例尺不在可计算之列,请检查你的比例尺"
Exit Sub

End Select


zarea = zarea + txtarea
ms = Format(txtarea / 666.6666, "#0.000")
txtarea = Format(txtarea, "#0.000")

txtins = "S=" & txtarea & "平方米=" & ms & "亩"

Set txtobj = ThisDrawing.ModelSpace.AddText(txtins, areains, 5)

txtobj.Color = acGreen



Dim ptype As Long
pname = "ANSI31"
ptype = 0

Set hatchobj = ThisDrawing.ModelSpace.AddHatch(ptype, pname, True)
hatchobj.PatternScale = 5

Set outloop(0) = entity

hatchobj.AppendOuterLoop (outloop)
hatchobj.Evaluate
End If

Next
ThisDrawing.Utility.Prompt "总面积为：" & zarea & "平方米"
sset.Clear
sset.Delete
End Sub

ld19791116

请问LISP语言网上电子教程在哪可下载?谢谢