[编程申请]：求去除孤岛的面积

ShiwJeff · 发表于 2003-9-18 22:54:07

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

有一闭合pl线，里面有若干闭合pl线（孤岛），求，去除孤岛后的面积。请各位高手帮忙，谢谢……

lsjjm · 发表于 2003-9-19 04:33:03

去除孤岛后的面积:
(defun c:test ()
 (vl-load-com)
 (setq ent (car (entsel "\nSelect Original Polyline: ")))
 (setq a0 (curvearea ent))
 (prompt "\nSelect Island Polyline: ")
 (setq ss (ssget) n 0 sum 0)
 (while (< n (sslength ss))
(setq sum (+ sum (curvearea (ssname ss n))))
(setq n (1+ n))
 )
 (- a0 sum)
)
(defun curvearea (ent)
 (setq obj (vlax-ename->vla-object ent))
 (setq ar (vla-get-area obj))
 ar
)

ShiwJeff · 发表于 2003-9-20 22:38:42

谢谢青铜长老。
假设里面有很多个孤岛，或者说有n个，难以逐个点出，能否只选择最外面的pl后，里面的pl闭合区域面积自动扣除。

shisj · 发表于 2004-8-6 11:34:37

看不太懂，还得提高学习，好像只能求闭合的实体面积，不能求由直线组成的面积。

playboy · 发表于 2004-8-6 16:17:45

最初由 ShiwJeff 发布
[B]谢谢青铜长老。
假设里面有很多个孤岛，或者说有n个，难以逐个点出，能否只选择最外面的pl后，里面的pl闭合区域面积自动扣除。 [/B]

可以啊
做循环就可以了
先求一个大的
用ssget w 取出所有的面
然后相减就可以了

xxxyzxx · 发表于 2004-11-23 13:34:30

晕，竟然有这么好的工具，可惜不能对填充求面积：（～～，我去想想该怎么改～～

hisen · 发表于 2004-11-23 13:52:25

test
Select Original Polyline: ; 错误: ActiveX 服务器返回错误: 未知名称: Area

lsjjm · 发表于 2004-11-24 03:45:19

最初由 xxxyzxx 发布
[B]晕，竟然有这么好的工具，可惜不能对填充求面积：（～～，我去想想该怎么改～～ [/B]

搜索一下论坛就知道了，请参考:
重建填充(hatch边界并求面积
http://www.xdcad.net/forum/showthre...threadid=161134

它山之石 · 发表于 2004-11-24 12:18:28

　　这是我写的面积相关程序的一部分，其中JMJ命令就是利用了楼主所说的原理来计算基底净面积的。MJS命令可以设置比例等。

;;; =============================================
;;; | 面积相关程序 |
;;; | Update: 2004.09.18 |
;;; =============================================
(defun C:mjs (/ ctscale htccale xdw xdws)
(setvar "CMDECHO" 0)
(if (= cts nil)
(setq cts 100)
)
(setq
ctscale (getreal (strcat "\n出图比例(1:?) <" (rtos cts 2 0) ">:"))
)
(if (= ctscale nil)
(setq ctscale cts)
)
(setq cts ctscale)
(if (= htc nil)
(setq htc 100)
)
(setq
htccale (getreal (strcat "\n绘图比例(1:?) <" (rtos htc 2 0) ">:"))
)
(if (= htccale nil)
(setq htccale htc)
)
(setq htc htccale)
(if (or (= xd nil) (= xd ""))
(setq xd "M")
)
(setq xdw (getstring (strcat "\n显示单位 <" xd ">:")))
(if (= xdw "")
(setq xdw xd)
)
(setq xd xdw)
(cond ((or (eq xdw "mm") (eq xdw "MM")) (setq xdws 1))
((or (eq xdw "cm") (eq xdw "CM")) (setq xdws 1000))
((or (eq xdw "m") (eq xdw "M")) (setq xdws 1000000))
)
(setq mj_sc (* (* (/ ctscale htccale) (/ ctscale htccale)) xdws))
(princ)
)
(defun C:jmj (/ ss sss sc os xzs pt n stm stmm mj_txt mjm_txt mjj_txt
test)
(princ (strcat "\n***基底面积自动计算软件040201***"))
(princ (strcat "\n [它山之石作品]"))
(princ)
(command "undo" "be")
(setq olderr *error* ; Initialize variables
*error* chgterr
)
(setvar "CMDECHO" 0)
(setq os (getvar "OSMODE"))
(setvar "OSMODE"
(if (> os 16383)
os
(+ 16384 os)
)
)
(setq lay (getvar "clayer"))
(if mj_sc
(setq mj_sc mj_sc)
(setq mj_sc 1000000)
)
(if xd
(setq xd xd)
(setq xd "m")
)
(if (or (= nil (tblsearch "layer" "文字__面积"))
(/= (cdr (assoc 8 (tblsearch "layer" "文字__面积"))) 0)
)
(command "layer" "m" "文字__面积" "c" "255" "文字__面积" "")
(command "layer" "s" "文字__面积" "" "")
)
;;; 如果图中原有面域则删除
(setq ss (ssget "X" '((0 . "REGION"))))
(if ss
(command "erase" ss "")
)
(setq pt (getpoint "\n请点取基底范围内一点<退出>:"))
(if pt
(progn
(setvar "HPBOUND" 0)
(command "boundary" pt "")
(setq ss (ssget "X" '((0 . "REGION"))))
(if ss ; 如果选取到了实体
(progn
(setq xzs (sslength ss))
(setq mjm_txt 0) ;mj_txt---重叠面积
(setq n 1) ;n---实体数
(while (<= n xzs) ;对选取的实体逐个进行处理
(setq stm (ssname ss (1- n))) ;stm---实体名称
(command "area" "o" stm)
(setq mjj_txt (getvar "AREA")) ;mj_txt---重叠面积
(if (< mjm_txt Mjj_txt)
(setq stmm stm
Mjm_txt Mjj_txt
)
)
(setq n (+ 1 n)) ;下一个实体
) ;while
(setq sss (ssadd)) ;ss---获得生成的面域实体
(setq sss (ssadd stmm sss)) ;获得生成的面域实体
(setq ss (ssdel stmm ss)) ;获得生成的面域实体
(if (< 1 xzs)
(command "subtract" sss "" ss "")
) ;如果获得了一个以上的面域，则生成交集。
(command "area" "o" (entlast)) ;获得交集的面积
(setq mj_txt (getvar "AREA")) ;mj_txt---交集面积
(setq mj_txt (rtos (/ mj_txt mj_sc) 2 2))
(setq mjm_txt (rtos (/ mjm_txt mj_sc) 2 2))
(cond ((or (eq xd "mm") (eq xd "MM"))
(alert (strcat "基底外包面积为: "
mjm_txt
" 平方毫米基底净面积为: "
mj_txt
" 平方毫米"
)
)
)
((or (eq xd "cm") (eq xd "CM"))
(alert (strcat "基底外包面积为: "
mjm_txt
" 平方厘米基底净面积为: "
mj_txt
" 平方厘米"
)
)
)
((or (eq xd "m") (eq xd "M"))
(alert (strcat "基底外包面积为: "
mjm_txt
" 平方米基底净面积为: "
mj_txt
" 平方米"
)
)
)
)
) ;progn ss
(alert (strcat "\n无法得到正确的基底边界"))
) ;if ss
) ;progn pt
) ;if pt
(command "layer" "s" lay "")
(setvar "osmode" os)
(setq *error* olderr) ; Restore old *error* handler
(command "undo" "e")
(command "undo" "")
(princ (strcat "\n***基底面积自动计算软件040201***"))
(princ (strcat "\n [它山之石作品]"))
(princ)
)

;;;       ============================================= 
;;;       |              面积相关程序                 | 
;;;       |           Update: 2004.09.18              | 
;;;       ============================================= 
 
(defun C:mjs (/ ctscale htccale xdw xdws) 
  (setvar "CMDECHO" 0) 
 
  (if (= cts nil) 
    (setq cts 100) 
  ) 
  (setq 
    ctscale (getreal (strcat "\n出图比例(1:?) <" (rtos cts 2 0) ">:")) 
  ) 
  (if (= ctscale nil) 
    (setq ctscale cts) 
  ) 
  (setq cts ctscale) 
 
  (if (= htc nil) 
    (setq htc 100) 
  ) 
  (setq 
    htccale (getreal (strcat "\n绘图比例(1:?) <" (rtos htc 2 0) ">:")) 
  ) 
  (if (= htccale nil) 
    (setq htccale htc) 
  ) 
  (setq htc htccale) 
 
  (if (or (= xd nil) (= xd "")) 
    (setq xd "M") 
  ) 
  (setq xdw (getstring (strcat "\n显示单位 <" xd ">:"))) 
  (if (= xdw "") 
    (setq xdw xd) 
  ) 
  (setq xd xdw) 
  (cond        ((or (eq xdw "mm") (eq xdw "MM")) (setq xdws 1)) 
        ((or (eq xdw "cm") (eq xdw "CM")) (setq xdws 1000)) 
        ((or (eq xdw "m") (eq xdw "M")) (setq xdws 1000000)) 
  ) 
  (setq mj_sc (* (* (/ ctscale htccale) (/ ctscale htccale)) xdws)) 
  (princ) 
 
) 
 
(defun C:jmj (/        ss sss sc os xzs pt n stm stmm mj_txt mjm_txt mjj_txt 
              test) 
 
  (princ (strcat "\n***基底面积自动计算软件040201***")) 
  (princ (strcat "\n       [它山之石作品]")) 
  (princ) 
 
  (command "undo" "be") 
  (setq        olderr        *error*                        ; Initialize variables 
        *error*        chgterr 
  ) 
  (setvar "CMDECHO" 0) 
 
  (setq os (getvar "OSMODE")) 
  (setvar "OSMODE" 
          (if (> os 16383) 
            os 
            (+ 16384 os) 
          ) 
  ) 
  (setq lay (getvar "clayer")) 
  (if mj_sc 
    (setq mj_sc mj_sc) 
    (setq mj_sc 1000000) 
  ) 
  (if xd 
    (setq xd xd) 
    (setq xd "m") 
  ) 
 
  (if (or (= nil (tblsearch "layer" "文字__面积")) 
          (/= (cdr (assoc 8 (tblsearch "layer" "文字__面积"))) 0) 
      ) 
    (command "layer" "m" "文字__面积" "c" "255" "文字__面积" "") 
    (command "layer" "s" "文字__面积" "" "") 
  ) 
;;; 如果图中原有面域则删除 
  (setq ss (ssget "X" '((0 . "REGION")))) 
  (if ss 
    (command "erase" ss "") 
  ) 
 
  (setq pt (getpoint "\n请点取基底范围内一点<退出>:")) 
  (if pt 
    (progn 
      (setvar "HPBOUND" 0) 
      (command "boundary" pt "") 
      (setq ss (ssget "X" '((0 . "REGION")))) 
 
 
 
      (if ss                                ; 如果选取到了实体 
        (progn 
          (setq xzs (sslength ss)) 
          (setq mjm_txt 0)                ;mj_txt---重叠面积 
 
          (setq n 1)                        ;n---实体数 
          (while (<= n xzs)                ;对选取的实体逐个进行处理 
            (setq stm (ssname ss (1- n))) ;stm---实体名称 
            (command "area" "o" stm) 
            (setq mjj_txt (getvar "AREA")) ;mj_txt---重叠面积 
            (if        (< mjm_txt Mjj_txt) 
              (setq stmm    stm 
                    Mjm_txt Mjj_txt 
              ) 
            ) 
            (setq n (+ 1 n))                ;下一个实体 
          )                                ;while 
 
 
          (setq sss (ssadd))                ;ss---获得生成的面域实体 
          (setq sss (ssadd stmm sss))        ;获得生成的面域实体 
          (setq ss (ssdel stmm ss))        ;获得生成的面域实体 
          (if (< 1 xzs) 
            (command "subtract" sss "" ss "") 
          )                                ;如果获得了一个以上的面域，则生成交集。 
          (command "area" "o" (entlast)) ;获得交集的面积 
          (setq mj_txt (getvar "AREA"))        ;mj_txt---交集面积 
          (setq mj_txt (rtos (/ mj_txt mj_sc) 2 2)) 
          (setq mjm_txt (rtos (/ mjm_txt mj_sc) 2 2)) 
          (cond        ((or (eq xd "mm") (eq xd "MM")) 
                 (alert        (strcat        "基底外包面积为: " 
                                mjm_txt 
                                " 平方毫米   基底净面积为: " 
                                mj_txt 
                                " 平方毫米" 
                               ) 
                 ) 
                ) 
                ((or (eq xd "cm") (eq xd "CM")) 
                 (alert        (strcat        "基底外包面积为: " 
                                mjm_txt 
                                " 平方厘米   基底净面积为: " 
                                mj_txt 
                                " 平方厘米" 
                               ) 
                 ) 
                ) 
                ((or (eq xd "m") (eq xd "M")) 
                 (alert        (strcat        "基底外包面积为: " 
                                mjm_txt 
                                " 平方米   基底净面积为: " 
                                mj_txt 
                                " 平方米" 
                               ) 
                 ) 
                ) 
          ) 
 
 
        )                                ;progn ss 
        (alert (strcat "\n无法得到正确的基底边界")) 
 
      )                                        ;if ss 
    )                                        ;progn pt 
  )                                        ;if pt 
 
  (command "layer" "s" lay "") 
  (setvar "osmode" os) 
  (setq *error* olderr)                        ; Restore old *error* handler 
  (command "undo" "e") 
  (command "undo" "") 
 
  (princ (strcat "\n***基底面积自动计算软件040201***")) 
  (princ (strcat "\n      [它山之石作品]")) 
  (princ) 
)

账号		自动登录	找回密码
密码			立即注册

[编程申请]：求 去除孤岛的面积

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

[编程申请]：求去除孤岛的面积