Meflying And 龍龍仔, 我寫的一個串聯選對象幫看看

BDYCAD

介绍:



        本程序是用来选一个对象后, 程序就自动找出这个对象相交的其他对象选到组成一个新的选集,         所以意思串联选择对象程序,


        附一个DWG文件和LISP程序一份1, 这个程序是刚完成的, 对我很有用. 只是有时候出错. 我看了很久发现不了不足的地方, 所以传一份上来请教两位, 看看怎么改进.

BDYCAD

程序代码

[Power=1]; 程序开发: 包达勇  [ BDYCAD ]
; 日期:     2004-10-29
; 开发时间   8:00~10.33 共用了两个小时33分
; 功能:　串联选择相交的ＳＰＬＩＮＥ
;;;(Strand-SelectObject [曲线对象]  [图层] )
;(Strand-SelectObject (car (entsel))  "0" )
; (setq 1-SPLINE (car (entsel)) lays "0")
(DEFUN Strand-SelectObject (1-SPLINE lays  / SSS End-Sel dib Slength S-p STP-1 STP-2 STP-3 STP-4  STP-5 STP-6 STP-7
        ttod S-del i is 2-SPLINE spt1 spt2 ept2)
  (defun xl-div-Strand (lst x / lst2)
    (foreach n lst
    (if (and  lst2 (/= x (length (car lst2))))
    (setq lst2 (cons (append (car lst2) (list n)) (cdr lst2)))
    (setq lst2 (cons (list n) lst2))))
    (reverse lst2))
  (defun x@_int-Strand-SelectObject (e1 e2 / obj1 obj1 ptlst ptints)
    (setq obj1 (vlax-ename->vla-object e1)
    obj2 (vlax-ename->vla-object e2)
       ptlst (append ptlst (xl-div-Strand (vlax-invoke obj1 'IntersectWith obj2 0) 3)))
  ptlst)
  (setq SSS (SSADD)  End-Sel 1-SPLINE dib 1.0 Slength (vlax-curve-getEndParam 1-SPLINE))
  (if (< Slength 30) (setq S-p (/ Slength 5))(setq S-p 12.0))
  (setq STP-1 (vlax-curve-getPointAtParam 1-SPLINE (vlax-curve-getstartparam 1-SPLINE)))
  (setq STP-2 (vlax-curve-getPointAtParam 1-SPLINE(- (vlax-curve-getstartparam 1-SPLINE) dib)))
  (setq STP-3 (vlax-curve-getPointAtParam 1-SPLINE (+ (vlax-curve-getstartparam 1-SPLINE) S-p)))
  (setq STP-4 (polar STP-2 (+ (* 0.5 pi) (angle STP-2 STP-1)) dib))
  (setq STP-5 (polar STP-4 (angle STP-4 STP-2) (* 2 dib)))
  (setq STP-6 (polar STP-4 (angle STP-2 STP-3) S-p))
  (setq STP-7 (polar STP-5 (angle STP-2 STP-3) S-p))
  (SSADD End-Sel SSS)
  (setq ttod 0 S-del (ssget "CP" (list STP-4  STP-5 STP-7 STP-6 STP-4 )
       (list (cons 0  "SPLINE") (cons 8 lays))))
  ;(vl-cmdf ".pline" STP-4 STP-5 STP-7 STP-6 "c")
  (ssdel 1-SPLINE S-del )
  (while (and S-del (/=(SSLENGTH S-del)0) (< ttod 100))
  (if (> (sslength S-del) 1)
    (progn
      (setq i 0)
    (repeat (sslength S-del)
      (setq is (ssname S-del i) i (1+ i))
      (if (=(x@_int-Strand-SelectObject is 1-SPLINE) nil) (ssdel is S-del)))))
  (if (= (sslength S-del) 1) (PROGN (SETQ 2-SPLINE (ssname S-del 0 )) (ssadd 2-SPLINE SSS)))
  (setq spt1 (vlax-curve-getstartpoint 1-SPLINE))
  (setq spt2 (vlax-curve-getstartpoint 2-SPLINE))
  (setq ept2 (vlax-curve-getendpoint 2-SPLINE))
  (if (> (distance STP-1 ept2) (distance spt1 spt2))
    (vl-cmdf ".splinedit" 2-SPLINE "E" "x"))
    (setq 1-SPLINE 2-SPLINE ttod (1+ ttod)Slength (vlax-curve-getEndParam 1-SPLINE))
   (if (< Slength 30) (setq S-p (/ Slength 5))(setq S-p 12.0))
  (setq STP-1 (vlax-curve-getPointAtParam 1-SPLINE (vlax-curve-getstartparam 1-SPLINE)))
  (setq STP-2 (vlax-curve-getPointAtParam 1-SPLINE(- (vlax-curve-getstartparam 1-SPLINE) dib)))
  (setq STP-3 (vlax-curve-getPointAtParam 1-SPLINE (+ (vlax-curve-getstartparam 1-SPLINE) S-p)))
  (setq STP-4 (polar STP-2 (+ (* 0.5 pi) (angle STP-2 STP-1)) dib))
  (setq STP-5 (polar STP-4 (angle STP-4 STP-2) (* 2 dib)))
  (setq STP-6 (polar STP-4 (angle STP-2 STP-3) S-p))
  (setq STP-7 (polar STP-5 (angle STP-2 STP-3) S-p))
    (setq S-del (ssget "f" (list STP-4  STP-5 STP-7 STP-6 STP-4) (list (cons 0  "SPLINE") (cons 8 lays))))
    ;(vl-cmdf ".pline" STP-4 STP-5 STP-7 STP-6 "c")
    (if (ssmemb End-Sel S-del) (setq S-del nil) (ssdel 1-SPLINE S-del ))
    )
  SSS)
(PRINC)[/Power]

龙龙仔

(setq TTOD 0
S-DEL (ssget "CP" ;S-DEL有可能为NIL,定义点有问题
(list STP-4 STP-5 STP-7 STP-6 STP-4)
(list (cons 0 "SPLINE") (cons 8 LAYS))
)
)

BDYCAD

龙龙仔, 关建就是选用这个方式的时有时选不到就出事了, 例出点的位置超出绘图区也会造成s-del变量为nil的. 还有就是有时候我发现(list STP-4 STP-5 STP-7 STP-6 STP-4)这几个点有时程序里面计算了会出错. 不知如何解决哦. .. .

meflying

使用选择前先ZOOM A 一下, 我也写了一个,,,跟你有点类似,不过选择方式上不同...

2. (vl-load-com)
3. (defun sscat(ss1 ss2 / i)
4.    (setq i 0)
5.    (cond
6.        ((not ss1) ss2)
7.        ((not ss2) ss1)
8.        (t (while (< i (sslength ss2))
9.    (ssadd (ssname ss2 i) ss1)
10.    (setq i (1+ i)))
11.          ss1)
12.    )
13. )
14. (defun ssred(ss1 ss2 / i)
15.    (setq i 0)
16.    (cond
17.        ((not ss1) nil)
18.        ((not ss2) ss1)
19.        (t (while (< i (sslength ss2))
20.    (ssdel (ssname ss2 i) ss1)
21.    (setq i (1+ i)))
22.          ss1)
23.    )
24. )
25. (defun HasInters (ent_1 ent_2 / ax_ent_1 ax_ent_2 intpoints)
26.    (setq ax_ent_1 (vlax-ename->vla-object ent_1)
27.                ax_ent_2 (vlax-ename->vla-object ent_2)
28.    )
29.    (setq intpoints (vla-intersectwith ax_ent_1 ax_ent_2 acextendboth))
30.    (setq intpoints (vlax-variant-value intpoints))
31.    (if (> (vlax-safearray-get-u-bound intpoints 1) 0)
32.        t
33.        nil
34.    )
35. );用法:(Strand-SelectObject (car (entsel))   "0" nil)
36. (DEFUN Strand-SelectObject (1-SPLINE lays ssOld / ss ssnew i ent ssnew)
37.    (vla-getboundingbox (vlax-ename->vla-object 1-spline) 'pt1 'pt2)
38.    (setq ss (ssget "c" (vlax-safearray->list pt1) (vlax-safearray->list pt2) (list '(0 . "SPLINE") (cons 8 lays))))
39.    ;(setq ss (ssget "x" (list '(0 . "spline") (cons 8 lays)));使用这个比较准确,但速度将减慢很多
40.    (setq i 0 ssnew (ssadd 1-spline))
41.    (repeat (sslength ss)
42.        (setq ent (ssname ss i))
43.        (if (HasInters ent 1-spline)
44.            (ssadd ent ssnew)
45.        )
46.        (setq i (1+ i))
47.    )
48.    (setq ssnew (ssred ssnew ssOld))
49.    (setq ssOld (sscat ssOld ssnew))
50.    (setq i 0)
51.    (repeat (sslength ssnew)
52.        (setq ssOld (Strand-SelectObject (ssname ssnew i) lays ssOld))
53.        (setq i (1+ i))
54.    )
55.    ssOld
56. )

(vl-load-com) (defun sscat(ss1 ss2 / i)    (setq i 0)    (cond        ((not ss1) ss2)        ((not ss2) ss1)        (t (while (< i (sslength ss2))    (ssadd (ssname ss2 i) ss1)    (setq i (1+ i)))          ss1)    ) ) (defun ssred(ss1 ss2 / i)    (setq i 0)    (cond        ((not ss1) nil)        ((not ss2) ss1)        (t (while (< i (sslength ss2))    (ssdel (ssname ss2 i) ss1)    (setq i (1+ i)))          ss1)    ) ) (defun HasInters (ent_1 ent_2 / ax_ent_1 ax_ent_2 intpoints)    (setq ax_ent_1 (vlax-ename->vla-object ent_1)                ax_ent_2 (vlax-ename->vla-object ent_2)    )    (setq intpoints (vla-intersectwith ax_ent_1 ax_ent_2 acextendboth))    (setq intpoints (vlax-variant-value intpoints))    (if (> (vlax-safearray-get-u-bound intpoints 1) 0)        t        nil    ) );用法:(Strand-SelectObject (car (entsel))   "0" nil) (DEFUN Strand-SelectObject (1-SPLINE lays ssOld / ss ssnew i ent ssnew)    (vla-getboundingbox (vlax-ename->vla-object 1-spline) 'pt1 'pt2)    (setq ss (ssget "c" (vlax-safearray->list pt1) (vlax-safearray->list pt2) (list '(0 . "SPLINE") (cons 8 lays))))    ;(setq ss (ssget "x" (list '(0 . "spline") (cons 8 lays)));使用这个比较准确,但速度将减慢很多    (setq i 0 ssnew (ssadd 1-spline))    (repeat (sslength ss)        (setq ent (ssname ss i))        (if (HasInters ent 1-spline)            (ssadd ent ssnew)        )        (setq i (1+ i))    )    (setq ssnew (ssred ssnew ssOld))    (setq ssOld (sscat ssOld ssnew))    (setq i 0)    (repeat (sslength ssnew)        (setq ssOld (Strand-SelectObject (ssname ssnew i) lays ssOld))        (setq i (1+ i))    )    ssOld )

BDYCAD

(DEFUN Strand-SelectObject (1-SPLINE lays ssOld / ss ssnew i ent ssnew)


使用时SSOLD不知你的用意呢？　可给个示例看看吧．　

meflying

已经更新了,


(Strand-SelectObject (car (entsel))         "0" nil)

龙龙仔

记得以前也提过EXPRESSTOOLS中指令 指令: FS Use 'FSMODE to control chain selection.
FSMODE = ON
Select touching object: 4 object(s) found.
Exiting Fastsel

BDYCAD

原来这里早有了

无痕

命令: (Strand-SelectObject (car (entsel)) "0" nil)
选择对象:
错误: 参数类型错误: lselsetp nil