谢谢版主，我按你说的办法去试试
lzh，alin两位高手，可以写一个程序出来参考参考么？
本帖最后由 作者 于 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
)
看到各位这么热心，我真是感动呀，我有什么好的东西一定首先放到这里来，谢谢大家!!!
本帖最后由 作者 于 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)
)
)
lzh741206发表于2004-9-20 22:25:00static/image/common/back.gif(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"))))恐怕要缩小一下范围。我是在程序开始设标志，选集选标志后的实体，这样在图大的时候快一些。
无痕发表于2004-9-20 17:22:00static/image/common/back.gif关于 交点－》做成面域 这一步，lzh有什么好方法么？
要知道一个交点打断后断点周围有4条线条，该怎么选来形成面域？
打断实体，试着用Region命令选择所有能够组合封闭区域的线条，看看什么结果<BR>
ea，我昨天已经试了，前面的几个帖子lzh也隐含了这个提示。呵呵，用了这么久的cad，这个技巧我以前都不知道呢。
谢谢大家
无痕发表于2004-9-23 0:40:00static/image/common/back.gif(defun tls-getarea( / l1 l2 i pnts ss1 s...
要是在VBA里我就是这么干的，Lisp还是不怎么熟悉，：）<BR></DIV>
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><FONT size=3>看来<B>无痕</B>是真没有用到<SPAN lang=EN-US>Autocad的3d功能,region是拉伸3D实体的基本功<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p></SPAN></FONT>
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><o:p><FONT size=3> </FONT></o:p>
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><FONT size=3>记得以前我写过一个生成<SPAN lang=EN-US>[立体文字]的程序就用到以上技术---</SPAN>打断建面域。<SPAN lang=EN-US><o:p></o:p></SPAN></FONT>
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><FONT size=3>当年打断还用<SPAN lang=EN-US>xdapi来做<o:p></o:p></FONT></SPAN>
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><o:p><FONT size=3></FONT></o:p>
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><o:p><FONT size=3></FONT></o:p>
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><o:p> </o:p>
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><FONT size=3>;;;注意:字型直线多的如"细明体系列"容易出错<o:p></o:p></FONT>
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt; TEXT-INDENT: 18pt; mso-char-indent-count: 1.5"><FONT size=3>(最后用上了打断建面域解决了字型问题)<BR>Sorry!以下连接没有用xdapi所以没有解决"细明体系列"容易出错的问题<SPAN lang=EN-US><o:p></o:p></SPAN></FONT>
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><A href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=115&replyID=368" target="_blank" ><FONT size=3>http://bbs.mjtd.com/forum.php?mod=viewthread&tid=115&replyID=368</FONT></A><o:p></o:p>
<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><o:p><FONT size=3> </FONT></o:p>