[LISP程序]：请教统计面积的好方法

00lg

请教统计面积的好方法。各位高手，小弟近来画规划图，经常要统计面积，用AREA命令一个一个点实在在慢（有几百个地块要统计），还容易出错。不知道谁有办法可以一次选了所有要统计面积的地块，然后一下子自动统计出来。应该编个LISP程序就可以的。先多谢了。

XDSoft

最初由 00lg 发布
[B]请教统计面积的好方法。各位高手，小弟近来画规划图，经常要统计面积，用AREA命令一个一个点实在在慢（有几百个地块要统计），还容易出错。不知道谁有办法可以一次选了所有要统计面积的地块，然后一下子自动统计出来... [/B]

规划图,你是用了填充吗? 如果是, 你去用下"晓东工具箱"下面"填充工具"里面的"计算填充面积"的工具.

00lg

当然不是填充，填充怎么可以用AREA计算出来呢？每个地块是一个封闭的多义线来的。

XDSoft

最初由 00lg 发布
[B]当然不是填充，填充怎么可以用AREA计算出来呢？每个地块是一个封闭的多义线来的。 [/B]

AREA 计算不了, 难道就不能写程序算啊:)

去下载晓东工具箱, 看看里面的曲线工具.

jx-lily

我用的是傻子方法。把PL线COPY一个出来，换到WALL层，炸开成L线，用天正的“房间面积”让电脑自己算。
还有可以用CAD的面积计算选OBJECT，点选PL线就可以了。

YAMA

如果用命令的话，可以考虑boundary,它可以得出边界线.

kytw

用我的程序试试看，估计能解决你的问题

eachy

以前写的一个程序[php]
;|
命令：Plarea

功能：计算封闭曲线（*polyline,spline,circle,ellipse)面积并标注

说明：用于统计曲线面积，包括三种方式：
      1. boundary方式，拾取点，如果生成边界则标面积
      2. 统计图层曲线面积
      3. 选择范围后标注所有曲线积   

      程序中标注数字采用了临时图层tmp_area，方便使用

      需配合xdrx_api build 11208以上版本使用。
|;
($xdrx_load "xdlsp.lsp")
(defun c:pl_area (/ kw redraw_le get_area get_layer_area get_point_area)
  (defun redraw_le ()
    (foreach e le_drw (redraw e 4))
    (foreach e le_del (entdel e))
    (setq le_drw nil
          le_del nil
    )
  )
  (defun get_area (l / _area ss ss0 ss1 e e1 info pt str len)
    (setq ss1        (ssadd)
          _area        0.0
    )
    (princ "\n选择拾取范围 (*polyline,circle,ellipse,spline)<全选>: ")
    (setq ss (ssget "x" l))
    (setq ss0 (ssget l)
          ss  (if ss0
                ss0
                ss
              )
    )
    (xdrx_setsstodb ss 0)
    (while (setq e (xdrx_getentdata 0))
      (setq info (xdrx_curve_info e))
      (setq pt (xdrx_midp (cadr (last info)) (caddr (last info))))
      (if (xdrx_curve_isclosed e)
        (progn
          (if (not (xdrx_getxdata e "面积"))
            (progn (setq str (rtos (/ (cadr (assoc "Area" info)) 1e6) 2 2))
                   (if (not (setq str (xdrx_getxdata e "面积")))
                     (progn (setq str (rtos (/ (cadr (assoc "Area" info)) 1e6) 2 2))
                            (xdrx_setxdata e "面积" str)
                     )
                     (setq str (car (xdrx_getxdata e "面积")))
                   )
            )
            (setq str (car (xdrx_getxdata e "面积")))
          )
          (setq _area (+ _area (read str)))
          (command ".text" "j" "mc" pt (* 3 bl) 0 str)
        )
        (setq ss1 (ssadd e ss1))
      )
    )
    (princ (strcat "\n\t总面积为 " (rtos _area 2 2) "。"))
    (if        (/= (sslength ss1) 0)
      (progn (If (And (Zerop (Getvar "cmdactive")) (Ssget "i"))
               (sssetfirst nil)
             )
             (xdrx_setsstodb ss1 0)
             (while (setq e1 (xdrx_getentdata 0))
               (redraw e1 3)
               (setq le_drw (cons e1 le_drw))
             )
             (redraw_le)
             (sssetfirst nil ss1)
             (setq len (rtos (sslength ss1) 2 0))
             (prompt (strcat "\n\t" "共 " len " 根非闭合多义线未标注面积。"))
      )
    )
  )
  (defun get_layer_area        (/ e)
    (setq e (xdrx_entsel "\n拾取实体: "))
    (princ (strcat "\n你已选择了 " (xdrx_getentdxf 8) " 层"))
    (get_area
      (list '(0 . "*polyline,circle,ellipse,spline") (cons 8 (xdrx_getentdxf 8)))
    )
  )
  (defun get_point_area        (/ p0 e str info tf)
    (setq p0 (getpoint "\n拾取标注范围内一点: "))
    (while p0
      (if (setq e (bpoly p0))
        (progn (setq info (xdrx_getarea e))
               (entdel (entlast))
               (setq str (rtos (/ (car info) 1e6) 2 2))
               (command ".text" "j" "mc" p0 (* 3 bl) 0 str)
        )
        (progn (xdrx_drawing_viewsave)
               (command ".zoom" ".3x")
               (setq tf T)
               (alert "无法找到范围, 重新选择！")
        )
      )
      (setq p0 (getpoint "\n拾取标注范围内一点: "))
    )
    (if        tf
      (xdrx_drawing_viewres)
    )
  )
  (xdrx_begin "tmp_area" "1")
  (xdrx_sysvar_push "cmdecho")
  (setvar "cmdecho" 0)
  (xdrx_ucson)
  (initget "1 2 3")
  (setq kw (getkword "\n[1 拾取点/2 按图层/3 选择范围]<3>: "))
  (cond        ((eq kw "1") (get_point_area))
        ((eq kw "2") (get_layer_area))
        (T (get_area '((0 . "*polyline,circle,ellipse,spline"))))
  )
  (xdrx_ucsoff)
  (xdrx_end)
  (xdrx_sysvar_pop)
  (princ)
)
(princ)
(prompt "\n\t面积标注工具之一Ver 1.0，命令C:pl_area。")
(princ)
[/php]

iwater

请问有统计多条直线长度的lisp程序吗？

自由的鱼

如果是封闭线计算面积就简单多了，看看这个程序能不能帮你解决问题

[php]
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) = "<or"

  
  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
[/php]

popxi

最初由 iwater 发布
[B]请问有统计多条直线长度的lisp程序吗？ [/B]

很好的工具
http://www.xdcad.net/forum/showthread.php?threadid=86458

lsjjm

最初由 00lg 发布
[B]请教统计面积的好方法...然后一下子自动统计出来... [/B]

请参考: (轮廓曲线不要求一定封闭)
(defun c:test ()
  (vl-load-com)
  (setq ss (ssget))
  (setq sum 0 n 0)
  (while (< n (sslength ss))
    (setq obj (vlax-ename->vla-object (ssname ss n)))
    (if (vlax-property-available-p obj "area")
      (setq sum (+ sum (vla-get-area obj)))
    )
    (setq n (1+ n))
  )
  sum
)

华山曲境

大家水平真高，都是CAD高级工程师

自由的鱼

这是一个很好的工具！
http://www.xdcad.net/forum/showthread.php?s=&threadid=152692

hitdjdj

好像这个也可以
http://www.xdcad.net/forum/showthread.php?s=&threadid=88930