[求助]如何求两交线之间的面积？多谢各位进来看看

墨色寒冰 · 发表于 2004-9-20 19:25:00

谢谢版主，我按你说的办法去试试

无痕 · 发表于 2004-9-20 20:42:00

lzh，alin两位高手，可以写一个程序出来参考参考么？

雪山飞狐_lzh · 发表于 2004-9-20 22:25:00

本帖最后由作者于 2004-9-21 15:05:22 编辑

(defun tls-getarea( / l1 l2 i pnts ss1 ss2 area)(defun tls-ssr(ss1 ss2 / i)
(setq i 0)
(repeat (sslength ss2)
(ssdel (ssname ss2 i) ss1)
(setq i (1+ i))
)
)(defun tls-breakatpnts(ent pnts / i lst count pnt)
(setq i 0 lst nil count (/ (length pnts) 3))
(repeat count
(setq
pnt (list (nth i pnts) (nth (1+ i) pnts) (nth (+ i 2) pnts))
pnt (cons (vlax-curve-getdistatpoint ent pnt) (list pnt))
lst (cons pnt lst)
i (+ i 3)
)
)
(setq lst
(vl-sort lst
(function (lambda (e1 e2) (> (car e1) (car e2))))
)
)
(setq i -1)
(repeat count
(setq pnt (cadr (nth (setq i (+ i 1)) lst)))
(command "_.break" (list ent pnt) pnt)
)
) (setvar "cmdecho" 0)
(setq
l1 (car (entsel))
l2 (car (entsel))
pnts
(vlax-safearray->list (vlax-variant-value (vla-IntersectWith
(vlax-ename->vla-object l1)
(vlax-ename->vla-object l2)
acExtendNone)))
ss1 (ssget "X")
)
(if (> (length pnts) 4)
(progn
(ssdel l1 ss1)
(ssdel l2 ss1)
(command "_.undo" "be")
(setq i 0)
(tls-breakatpnts l1 pnts)
(tls-breakatpnts l2 pnts)
(setq ss2 (ssget "X"))
(tls-ssr ss2 ss1)
(command "region" ss2 "")
(setq ss2 (ssget "X" '((0 . "REGION"))))
(tls-ssr ss2 ss1)
(setq i 0 area 0)
(repeat (sslength ss2)
(setq area (+ area (vla-get-area (vlax-ename->vla-object (ssname ss2 i)))))
(setq i (1+ i))
)
(command "_.undo" "e")
(command "_.undo" "1")
(setvar "cmdecho" 1)
)
)
area
)

(defun tls-getarea( / l1 l2 i pnts ss1 ss2 area)(defun tls-ssr(ss1 ss2 / i)
   (setq i 0)
   (repeat (sslength ss2)
       (ssdel (ssname ss2 i) ss1)
       (setq i (1+ i))
   )
)(defun tls-breakatpnts(ent pnts / i lst count pnt)
   (setq i 0 lst nil count (/ (length pnts) 3))
   (repeat count
       (setq 
           pnt (list (nth i pnts) (nth (1+ i) pnts) (nth (+ i 2) pnts))
           pnt (cons (vlax-curve-getdistatpoint ent pnt) (list pnt))
           lst (cons pnt lst)
           i (+ i 3)
       )
   )
   (setq lst 
       (vl-sort lst 
           (function (lambda (e1 e2) (> (car e1) (car e2))))
       )
   )
   (setq i -1)
   (repeat count
       (setq pnt (cadr (nth (setq i (+ i 1)) lst)))
       (command "_.break" (list ent pnt) pnt)
   )
)   (setvar "cmdecho" 0)
   (setq
       l1 (car (entsel))
       l2 (car (entsel))
       pnts 
           (vlax-safearray->list (vlax-variant-value (vla-IntersectWith
               (vlax-ename->vla-object l1)
               (vlax-ename->vla-object l2)
               acExtendNone)))
       ss1 (ssget "X")
   )
   (if (> (length pnts) 4) 
       (progn 
           (ssdel l1 ss1)
           (ssdel l2 ss1)
           (command "_.undo" "be")
           (setq i 0)
           (tls-breakatpnts l1 pnts)
           (tls-breakatpnts l2 pnts)
           (setq ss2 (ssget "X"))
           (tls-ssr ss2 ss1)
           (command "region" ss2 "")
           (setq ss2 (ssget "X" '((0 . "REGION"))))
           (tls-ssr ss2 ss1)
           (setq i 0 area 0)
           (repeat (sslength ss2)
               (setq area (+ area (vla-get-area (vlax-ename->vla-object (ssname ss2 i)))))
               (setq i (1+ i))
           )
           (command "_.undo" "e")
           (command "_.undo" "1")
           (setvar "cmdecho" 1)
       )
   )
area
)

墨色寒冰 · 发表于 2004-9-21 00:08:00

看到各位这么热心，我真是感动呀，我有什么好的东西一定首先放到这里来，谢谢大家!!!

alin · 发表于 2004-9-21 13:01:00

本帖最后由作者于 2004-9-21 14:10:34 编辑

;;;This routine calculate the total area between two plines or splines
;;; Please Zoom in as close as possible and check the number oF regions counted...Good luck!
;;;Author: Alin 21/9/04
(defun c:InterArea (/ ent_1 ent_2 idx
oldEcho oldOSmode elast ent_1
ent_2 interpts inter_dists_1 inter_dists_2
pt rad ent_cir pt1
innerpts pt2 innerpt interpts_with_circle_1
interpts_with_circle_2 enext enextHold
cnt)
(setq oldEcho (getvar "CMDECHO")
oldOSmode (getvar "OSMODE")
elast (entlast)
area 0.0
innerpts nil
interpts nil)
(setvar "CMDECHO" 0)
(setvar "OSMODE" 0)
(setq ent_1 (car (entsel "\nSelect the first spline:"))
ent_2 (car (entsel "\nSelect the second spline:"))
)
(if (and (setq interpts (GetInterPoints ent_1 ent_2))
(> (length interpts) 1))
(progn
(setq interpts (vl-sort interpts
'(lambda (e1 e2)
(< (vlax-curve-getdistatpoint ent_1 e1)
(vlax-curve-getdistatpoint ent_1 e2)))))
;;; (command "pline")
;;; (foreach ipt interpts
;;; (command ipt))
;;; (command "")
(setq inter_dists_1 (mapcar '(lambda (e) (vlax-curve-getdistatpoint ent_1 e))
interpts)
inter_dists_2 (mapcar '(lambda (e) (vlax-curve-getdistatpoint ent_2 e))
interpts)
)
(setq idx 0)
(repeat (1- (length interpts))
(setq pt (nth idx interpts))
(setq rad
(/ (min (abs
(- (nth idx inter_dists_1) (nth (1+ idx) inter_dists_1)))
(abs
(- (nth idx inter_dists_2) (nth (1+ idx) inter_dists_2))))
50.0))
(command "circle" pt rad)
(setq ent_cir (entlast))
(setq interpts_with_circle_1 (GetInterPoints ent_1 ent_cir)
interpts_with_circle_2 (GetInterPoints ent_2 ent_cir))
(if (= (length interpts_with_circle_1) 1)
(setq pt1 (car interpts_with_circle_1))
(if (or (< (nth idx inter_dists_1)
(vlax-curve-getdistatpoint
ent_1
(car interpts_with_circle_1))
(nth (1+ idx) inter_dists_1))
(> (nth idx inter_dists_1)
(vlax-curve-getdistatpoint
ent_1
(car interpts_with_circle_1))
(nth (1+ idx) inter_dists_1))
)
(setq pt1 (car interpts_with_circle_1))
(setq pt1 (cadr interpts_with_circle_1))
)
)
(if (= (length interpts_with_circle_2) 1)
(setq pt2 (car interpts_with_circle_2))
(if (or (< (nth idx inter_dists_2)
(vlax-curve-getdistatpoint
ent_2
(car interpts_with_circle_2))
(nth (1+ idx) inter_dists_2))
(> (nth idx inter_dists_2)
(vlax-curve-getdistatpoint
ent_2
(car interpts_with_circle_2))
(nth (1+ idx) inter_dists_2))
)
(setq pt2 (car interpts_with_circle_2))
(setq pt2 (cadr interpts_with_circle_2))
)
)
(setq innerpt (midpoint pt1 pt2))
(setq innerpts (cons innerpt innerpts))
(entdel ent_cir)
(setq idx (1+ idx))
)
(command "bpoly" "a" "o" "r" "")
(foreach innerpt innerpts
(command innerpt))
(command "")
;;; (command "pline")
;;; (foreach innerpt innerpts
;;; (command innerpt))
;;; (command "")
(if (setq enext (entnext elast))
(progn
(setq cnt 0)
(while enext
(setq area (+ area (vla-get-area (vlax-ename->vla-object enext))))
(setq enextHold enext
cnt (1+ cnt))
(setq enext (entnext enext))
(entdel enextHold)
)
(alert (strcat "Area = "
(rtos area 2 2)
"\n"
(itoa cnt)
" Regions counted."))
) ;progn
(princ
"\nNo regions created. Please Zoom in a little bit and try again...")
)
) ;progn
(alert "Number of intersection points < 2!")
)
(setvar "CMDECHO" oldEcho)
(setvar "OSMODE" oldOSmode)
(princ)
)
(defun GetInterPoints (ent_1 ent_2 / ax_ent_1 ax_ent_2 intpoints i Ptlist)
(setq ax_ent_1 (vlax-ename->vla-object ent_1)
ax_ent_2 (vlax-ename->vla-object ent_2)
)
(setq intpoints (vlax-variant-value
(vla-intersectwith ax_ent_1 ax_ent_2 acextendnone)))
(if (< (vlax-safearray-get-u-bound intpoints 1) 0)
nil
(progn
(setq intpoints (VLAX-safearray->list intpoints))
(setq i 0)
(repeat (/ (length intpoints) 3)
(setq Ptlist (cons (list (nth i intpoints)
(nth (1+ i) intpoints)
(nth (+ 2 i) intpoints))
Ptlist))
(setq i (+ i 3))
)
(reverse Ptlist)
)
)
)
;;;
;;;-----------------------------------------------
(defun midpoint (pt1 pt2)
(list (* (+ (car pt1) (car pt2)) 0.5)
(* (+ (cadr pt1) (cadr pt2)) 0.5)
(* (+ (caddr pt1) (caddr pt2)) 0.5)
)
)

;;;This routine calculate the total area between two plines or splines
;;; Please Zoom in as close as possible and check the number oF regions counted...Good luck!
;;;Author: Alin 21/9/04
(defun c:InterArea   (/                         ent_1                 ent_2                 idx
                                         oldEcho             oldOSmode         elast                 ent_1
                                         ent_2                 interpts           inter_dists_1 inter_dists_2
                                         pt                       rad                     ent_cir             pt1
                                         innerpts           pt2                     innerpt             interpts_with_circle_1
                                         interpts_with_circle_2           enext                 enextHold
                                         cnt)
   (setq oldEcho     (getvar "CMDECHO")
               oldOSmode (getvar "OSMODE")
               elast         (entlast)
               area           0.0
               innerpts   nil
               interpts nil)
   (setvar "CMDECHO" 0)
   (setvar "OSMODE" 0)
   (setq ent_1 (car (entsel "\nSelect the first spline:"))
               ent_2 (car (entsel "\nSelect the second spline:"))
               )
   (if (and (setq interpts (GetInterPoints ent_1 ent_2))
                     (> (length interpts) 1))
       (progn
           (setq interpts (vl-sort interpts
                                                           '(lambda (e1 e2)
                                                                 (< (vlax-curve-getdistatpoint ent_1 e1)
                                                                       (vlax-curve-getdistatpoint ent_1 e2)))))
;;;           (command "pline")
;;;           (foreach ipt   interpts
;;;               (command ipt))
;;;           (command "")
           (setq inter_dists_1 (mapcar '(lambda (e) (vlax-curve-getdistatpoint ent_1 e))
                                                                   interpts)
                       inter_dists_2 (mapcar '(lambda (e) (vlax-curve-getdistatpoint ent_2 e))
                                                                   interpts)
                       )
           (setq idx 0)
           (repeat (1- (length interpts))
               (setq pt (nth idx interpts))
               (setq rad
                             (/ (min (abs
                                                 (- (nth idx inter_dists_1) (nth (1+ idx) inter_dists_1)))
                                             (abs
                                                 (- (nth idx inter_dists_2) (nth (1+ idx) inter_dists_2))))
                                   50.0))
               (command "circle" pt rad)
               (setq ent_cir (entlast))
               (setq interpts_with_circle_1 (GetInterPoints ent_1 ent_cir)
                           interpts_with_circle_2 (GetInterPoints ent_2 ent_cir))
               (if (= (length interpts_with_circle_1) 1)
                   (setq pt1 (car interpts_with_circle_1))
                   (if (or (< (nth idx inter_dists_1)
                                         (vlax-curve-getdistatpoint
                                             ent_1
                                             (car interpts_with_circle_1))
                                         (nth (1+ idx) inter_dists_1))
                                   (> (nth idx inter_dists_1)
                                         (vlax-curve-getdistatpoint
                                             ent_1
                                             (car interpts_with_circle_1))
                                         (nth (1+ idx) inter_dists_1))
                                   )
                       (setq pt1 (car interpts_with_circle_1))
                       (setq pt1 (cadr interpts_with_circle_1))
                       )
                   )
               (if (= (length interpts_with_circle_2) 1)
                   (setq pt2 (car interpts_with_circle_2))
                   (if (or (< (nth idx inter_dists_2)
                                         (vlax-curve-getdistatpoint
                                             ent_2
                                             (car interpts_with_circle_2))
                                         (nth (1+ idx) inter_dists_2))
                                   (> (nth idx inter_dists_2)
                                         (vlax-curve-getdistatpoint
                                             ent_2
                                             (car interpts_with_circle_2))
                                         (nth (1+ idx) inter_dists_2))
                                   )
                       (setq pt2 (car interpts_with_circle_2))
                       (setq pt2 (cadr interpts_with_circle_2))
                       )
                   )
               (setq innerpt (midpoint pt1 pt2))
               (setq innerpts (cons innerpt innerpts))
               (entdel ent_cir)
               (setq idx (1+ idx))
               )
           (command "bpoly" "a" "o" "r" "")
           (foreach innerpt   innerpts
               (command innerpt))
           (command "")
;;;               (command "pline")
;;;                           (foreach innerpt innerpts
;;;                   (command innerpt))
;;;               (command "")           
           (if (setq enext (entnext elast))
               (progn
                   (setq cnt 0)
                   (while enext
                       (setq area (+ area (vla-get-area (vlax-ename->vla-object enext))))
                       (setq enextHold enext
                                   cnt (1+ cnt))
                       (setq enext (entnext enext))
                       (entdel enextHold)
                       )
                   (alert (strcat "Area = "
                                                 (rtos area 2 2)
                                                 "\n"
                                                 (itoa cnt)
                                                 " Regions counted."))
                   ) ;progn
               (princ
                   "\nNo regions created. Please Zoom in a little bit and try again...")
               )
           ) ;progn
       (alert "Number of intersection points < 2!")
       )
   (setvar "CMDECHO" oldEcho)
   (setvar "OSMODE" oldOSmode)
   (princ)
   ) 
(defun GetInterPoints   (ent_1 ent_2 / ax_ent_1 ax_ent_2 intpoints i Ptlist)
   (setq ax_ent_1 (vlax-ename->vla-object ent_1)
               ax_ent_2 (vlax-ename->vla-object ent_2)
               )
   (setq intpoints (vlax-variant-value
                                       (vla-intersectwith ax_ent_1 ax_ent_2 acextendnone)))
   (if (< (vlax-safearray-get-u-bound intpoints 1) 0)
       nil
       (progn
           (setq intpoints (VLAX-safearray->list intpoints))
           (setq i 0)
           (repeat (/ (length intpoints) 3)
               (setq Ptlist (cons (list (nth i intpoints)
                                                                 (nth (1+ i) intpoints)
                                                                 (nth (+ 2 i) intpoints))
                                                     Ptlist))
               (setq i (+ i 3))
               )
           (reverse Ptlist)
           )
       )
   )
;;;
;;;-----------------------------------------------
(defun midpoint   (pt1 pt2)
   (list (* (+ (car pt1) (car pt2)) 0.5)
               (* (+ (cadr pt1) (cadr pt2)) 0.5)
               (* (+ (caddr pt1) (caddr pt2)) 0.5)
               )
   )

无痕 · 发表于 2004-9-23 00:40:00

lzh741206发表于2004-9-20 22:25:00(defun tls-getarea( / l1 l2 i pnts ss1 ss2 area) (defun tls-ssr(ss1 ss2 / i) (setq i 0) (repeat (sslength ss2) ...

程序不错，你后来把排序部分补充完成了吧：）我也写了一个，写完再看你的程序，步骤差不多：）

复制代码

另，你的那句(setq ss2 (ssget "X" '((0 . "REGION"))))恐怕要缩小一下范围。我是在程序开始设标志，选集选标志后的实体，这样在图大的时候快一些。

Ea · 发表于 2004-9-23 00:42:00

无痕发表于2004-9-20 17:22:00关于交点－》做成面域这一步，lzh有什么好方法么？要知道一个交点打断后断点周围有4条线条，该怎么选来形成面域？

打断实体，试着用Region命令选择所有能够组合封闭区域的线条，看看什么结果

无痕 · 发表于 2004-9-23 00:44:00

ea，我昨天已经试了，前面的几个帖子lzh也隐含了这个提示。呵呵，用了这么久的cad，这个技巧我以前都不知道呢。

谢谢大家

雪山飞狐_lzh · 发表于 2004-9-23 08:51:00

无痕发表于2004-9-23 0:40:00(defun tls-getarea( / l1 l2 i pnts ss1 s...

要是在VBA里我就是这么干的，Lisp还是不怎么熟悉，：）

龙龙仔 · 发表于 2004-9-23 10:49:00

看来无痕是真没有用到Autocad的3d功能,region是拉伸3D实体的基本功

记得以前我写过一个生成[立体文字]的程序就用到以上技术---打断建面域。

当年打断还用xdapi来做

;;;注意:字型直线多的如"细明体系列"容易出错

(最后用上了打断建面域解决了字型问题)
Sorry!以下连接没有用xdapi所以没有解决"细明体系列"容易出错的问题

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=115&replyID=368

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

[求助]如何求两交线之间的面积？多谢各位进来看看

本帖子中包含更多资源