[分享]宽PL线转线框，PL线剪影
本帖最后由 作者 于 2010-8-31 21:36:52 编辑宽LWPOLYLINE转线框，相当于剪影功能
采用纯VLISP方式实现将宽度>0的LWPOLYLINE转线框，对圆弧段采用3段圆弧模拟。
file:///D://PPL.bmp
源码如下：
主框架源码
;;;------------------------------------------------------------------------;;;
;;;宽POLYLINE转线框程序
(defun c:PPL (/ ssen)
(setq ssen (wjm_ss2lst (ssget (list (cons 0 "LWPOLYLINE")))))
(foreach a ssen
(ss-WPL->PL a T)
(entdel a)
)
(princ "\n高山流水宽PL线转线框程序,命令PPL")
(princ)
)
;;;------------------------------------------------------------------------;;;
(defun c:PPL1 (/ ssen)
(setq ssen (wjm_ss2lst (ssget (list (cons 0 "LWPOLYLINE")))))
(foreach a ssen
(ss-WPL->PL a NIL)
(entdel a)
)
(princ "\n高山流水宽PL线转单段线框程序,命令PPL1")
(princ)
)
;;; ---------------------------------------------------------------------------;;;
;;; SS-WPL->PL ;;;
;;; ---------------------------------------------------------------------------;;;
;;; function : Translate Wide LwPolyLine into Frame Border ;;;
;;; Arg : ;;;
;;; pl - PL Ename ;;;
;;; bool - boolean, T or NIL ;;;
;;; If you provide T , Then it'll translate PL to a Closed PL-Frame, ;;;
;;; If it's NIL , Single-stage PL-Frame. ;;;
;;; GE Alg : ;;;
;;; Trisect ARC length and width, Combine sidelines with Convexity ;;;
;;; ---------------------------------------------------------------------------;;;
;;; Example: ;;;
;;; (SS-WPL->PL PL_Ename T) ;_Return a Closed PL-Frame ;;;
;;; ---------------------------------------------------------------------------;;;
;;; Writen By GSLS(SS) 2010-08-08 ;;;
;;; (C) EasyCity OptDesign Studio of Building Structures ;;;
;;; Email: chlh_jd@126.com Tel:0592-5391029 Fax:0592-5391020 ;;;
;;; ---------------------------------------------------------------------------;;;
(defun SS-WPL->PL (pl bool)
(if bool
;;;整条返回封闭POLYLINE
(mapcar 'entmake (ss-PL->Bound pl))
;;;逐段返回封闭POLYLINE
(ss-pl->sbound pl)
)
)
主函数源码1:
(defun SS-PL->Bound (pl / ent is_close pl_vetex
b i lst1 lst2w02 c0 p1
p2 w11 w12 c1b mid mid1
mid2 mid3 mid4 mid5mid6 from1from2
mpt1 mpt2 m1 m2mpt1 mpt2 ang
dis1 dis2 mptl1mptr1mptl2 mptr2n1
n2 m3 m4 end
)
(setq ent (entget pl '("*")))
(setq is_close (rem (cdr (assoc 70 ent)) 2))
(setq pl_vetex nil
b nil
)
(foreach n ent ;_(setq e (assoc 10 ent))
(if (or (= 10 (car n))
(= 40 (car n))
(= 41 (car n))
(= 42 (car n))
) ;_ 结束or
(progn
(setq b (cons (cdr n) b))
(if (= 4 (length b))
(setq pl_vetex (append pl_vetex (list (reverse b)))
bnil
)
)
)
)
)
(setq i 0
lst1 nil
lst2 nil
w02nil
c0 nil
)
(foreach a pl_vetex
(setq p1 (car a)
w11 (cadr a)
w12 (caddr a)
c1 (cadddr a)
b (nth (1+ i) pl_vetex)
mid nil
mid1 nil
mid2 nil
from1 nil
form2 nil
)
(if (and (null b) (= is_close 1))
(setq b (car pl_vetex))
)
(if (setq p2 (car b))
(progn
(setq mid (ss-plwk-pts p1 w11 w12 c1 p2))
(if
(or (null c0) (null w02)) ;_第一段
(repeat (/ (length mid) 2)
(setq lst1 (cons (car mid) lst1)
lst2 (cons (cadr mid) lst2)
mid (cddr mid)
)
)
(progn
(setq from1 (car lst1)
lst1(cdr lst1)
from2 (car lst2)
lst2(cdr lst2)
)
(cond
;;;
;;;_1同为直段
((= c0 c1 0.0)
(setq mid1 (car mid)
mid2 (cadr mid)
)
(cond
((= w02 w11)
(if (setq mpt1 (inters (car from1)
(cadr from1)
(car mid1)
(cadr mid1)
nil
)
)
(progn
(setq mpt2 (inters (car from2)
(cadr from2)
(car mid2)
(cadr mid2)
nil
)
)
;;_无需再次判别连接
(setq lst1 (cons (ch-lst mpt1 1 from1) lst1)
lst2 (cons (ch-lst mpt2 1 from2) lst2)
lst1 (cons (ch-lst mpt1 0 mid1) lst1)
lst2 (cons (ch-lst mpt2 0 mid2) lst2)
)
)
(setq lst1 (cons mid1 (cons from1 lst1))
lst2 (cons mid2 (cons from2 lst2))
)
)
) ;_end cond 2.1
((> w02 w11) ;_前宽后窄
(setq mpt1 (inters (car mid1)
(cadr mid1)
(car from1)
(cadr from1)
nil
)
mpt2 (inters (car mid2)
(cadr mid2)
(car from2)
(cadr from2)
nil
)
) ;_(check-pt (list mpt1 mpt2))
(if (and mpt1 mpt2) ;_不存在交点，则平行
(progn ;_存在交点
;_有个问题，是取宽端点连线交点，还是取与宽边交点？??????????????????????????????????????????
;_暂时按方向角改变在[- pi/6 pi/6]
(if
(or
(<=
(/ pi -6.0)
(- (gsls-ang-trans
(angle
(midpt (car from1) (car from2))
(midpt (cadr from1) (cadr from2))
)
)
(gsls-ang-trans
(angle (midpt (car mid1) (car mid2))
(midpt (cadr mid1) (cadr mid2))
)
)
)
(/ pi 6.0)
)
(/= w01 0.0)
)
(setq mpt1 (inters (cadr from1)
(cadr from2)
(car mid1)
(cadr mid1)
nil
)
mpt2 (inters (cadr from1)
(cadr from2)
(car mid2)
(cadr mid2)
nil
)
lst1 (cons (ch-lst mpt1 0 mid1)
(cons from1 lst1)
)
lst2 (cons (ch-lst mpt2 0 mid2)
(cons from2 lst2)
)
)
(setq
mid1(ch-lst mpt1 0 mid1)
mid2(ch-lst mpt2 0 mid2)
from1 (ch-lst mpt1 1 from1)
from2 (ch-lst mpt2 1 from2)
lst1(cons mid1 (cons from1 lst1))
lst2(cons mid2 (cons from2 lst2))
)
)
)
;;_平行
(setq lst1 (cons mid1 (cons from1 lst1))
lst2 (cons mid2 (cons from2 lst2))
)
)
)
((< w02 w11)
(setq mpt1 (inters (car mid1)
(cadr mid1)
(car from1)
(cadr from1)
nil
)
mpt2 (inters (car mid2)
(cadr mid2)
(car from2)
(cadr from2)
nil
)
)
(if (and mpt1 mpt2) ;_不存在交点，则平行
(progn ;_存在交点
;_有个问题，是取宽端点连线交点，还是取与宽边交点？??????????????????????????????????????????
;_暂时按方向角改变在[- pi/6 pi/6]
(if (<= (/ pi -6.0)
(- (gsls-ang-trans
(angle (car from1) (cadr from1))
)
(gsls-ang-trans
(angle (car mid1) (cadr mid1))
)
)
(/ pi 6.0)
)
(setq mpt1 (inters (car from1)
(cadr from2)
(car mid1)
(car mid2)
nil
)
mpt2 (inters (car from1)
(cadr from2)
(car mid1)
(car mid2)
nil
)
lst1 (cons mid1
(cons (ch-lst mpt1 1 from1) lst1)
)
lst2 (cons mid2
(cons (ch-lst mpt2 1 from2) lst2)
)
)
(setq mpt1(inters (car mid1)
(cadr mid1)
(car from1)
(cadr from1)
nil
)
mpt2(inters (car mid2)
(cadr mid2)
(car from2)
(cadr from2)
nil
)
mid1(ch-lst mpt1 0 mid1)
mid2(ch-lst mpt2 0 mid2)
from1 (ch-lst mpt1 1 from1)
from2 (ch-lst mpt2 1 from2)
lst1(cons mid1 (cons from1 lst1))
lst2(cons mid2 (cons from2 lst2))
)
)
)
;_平行
(setq lst1 (cons mid1 (cons from1 lst1))
lst2 (cons mid2 (cons from2 lst2))
)
) ;_end if
) ;_前窄后宽
)
)
;;;
;;;_2前段直段，后段弧
((and (= c0 0.0) (/= c1 0.0))
;(check-pt (cdr (reverse from1)))
(setq mid1 (car mid)
mid2 (cadr mid)
mid(cddr mid)
mid3 (car mid)
mid4 (cadr mid)
mid(cddr mid)
mid5 (car mid)
mid6 (cadr mid)
m1 (SS-PTC-ptcR
(car mid1)
(cadr mid1)
(caddr mid1)
)
m2 (SS-PTC-ptcR
(car mid2)
(cadr mid2)
(caddr mid2)
)
m3 (SS-PTC-ptcR
p1
p2
c1
)
mpt1 (get-mindis-pt (ss-pl-inters from1 mid1) p1)
mpt2 (get-mindis-pt (ss-pl-inters from2 mid2) p1) ;_(check-pt (list (car from2) (cadr from2)))
)
(cond
((= w02 w11) ;_2.1等宽
(if (or mpt1 mpt2)
(progn
(if mpt1
nil
(setq mpt1
(get-mindis-pt
(ss-pl-inters from1 (list p1 mpt2 0.0))
p1
)
)
)
(if mpt2
nil
(setq mpt2
(get-mindis-pt
(ss-pl-inters from2 (list p1 mpt1 0.0))
p1
)
)
)
)
(progn
(setq
mpt1 (pedal_to_line
(car m1)
(car from1)
(cadr from1)
)
mpt2 (pedal_to_line
(car m2)
(car from2)
(cadr from2)
)
ang(angle (car from1) (cadr from1))
)
(if
(equal (cadr m1)
(distance (car m1) mpt1)
2e-6
)
(setq dis1 0.0)
(setq
dis1
(sqrt (- (expt (cadr m1) 2.0)
(expt (distance (car m1) mpt1) 2.0)
)
)
)
)
(if
(equal (cadr m2)
(distance (car m2) mpt2)
2e-6
)
(setq dis2 0.0)
(setq
dis2
(sqrt (- (expt (cadr m2) 2.0)
(expt (distance (car m2) mpt2) 2.0)
)
)
)
)
(setq
mptl1 (polar mpt1 (+ ang pi) dis1)
mptr1 (polar mpt1 ang dis1)
mptl2 (polar mpt2 (+ ang pi) dis2)
mptr2 (polar mpt2 ang dis2)
)
(cond ((> (distance mptl1 (car mid1))
(distance mptr1 (car mid1))
)
(setq mpt1 mptr1)
)
((< (distance mptl1 (car mid1))
(distance mptr1 (car mid1))
)
(setq mpt1 mptl1)
)
(t
(setq mpt1 (midpt mptl1 mptr1)) ;_这里需要推敲下,求中点消除误差
)
)
(cond ((> (distance mptl2 (car mid2))
(distance mptr2 (car mid2))
)
(setq mpt2 mptr2)
)
((< (distance mptl2 (car mid2))
(distance mptr2 (car mid2))
)
(setq mpt2 mptl2)
)
(t
(setq mpt2 (midpt mptl2 mptr2))
)
)
)
)
(setq n1 (ss-ptc-c mpt1
(cadr mid1)
(car m1)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m2)
(> (caddr mid2) 0.0)
)
)
(setq lst1 (cons (ch-lst
mpt1
1
from1
)
lst1
) ;_
lst2 (cons (ch-lst
mpt2
1
from2
)
lst2
) ;_
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
)
((> w02 w11) ;_2.2前宽后窄
;_(command "line" (list 0 0 0) mpt2 "")
(setq mpt1 (get-mindis-pt
(ss-pl-inters
(list (cadr from1) (cadr from2) 0.0)
mid1
)
(car mid1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
(list (cadr from1) (cadr from2) 0.0)
mid2
)
(car mid2)
)
)
(if (and mpt1 mpt2) ;_这里需要调整下，可能存在一个交点，也是符合第一项处理
(progn
(setq n1 (ss-ptc-c mpt1
(cadr mid1)
(car m1)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m2)
(> (caddr mid2) 0.0)
)
)
(setq lst1 (cons from1 lst1)
lst2 (cons from2 lst2)
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
)
(progn
(setq mpt1 (get-mindis-pt
(ss-pl-inters
from1
mid1
)
(car mid1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
from2
mid2
)
(car mid2)
)
)
(setq n1 (ss-ptc-c mpt1
(cadr mid1)
(car m1)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m2)
(> (caddr mid2) 0.0)
)
)
(setq from1 (ch-lst mpt1 1 from1)
from2 (ch-lst mpt2 1 from2)
mid1(ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2(ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1(cons from1 lst1)
lst2(cons from2 lst2)
lst1(cons mid1 lst1)
lst2(cons mid2 lst2)
)
)
)
)
((< w02 w11) ;_2.3前窄后款
(setq mpt1 (car (ss-pl-inters
from1
(list (car mid1) (car mid2) 0.0)
)
)
mpt2 (car (ss-pl-inters
from2
(list (car mid1) (car mid2) 0.0)
)
)
)
(if (and mpt1 mpt2)
(setq lst1 (cons (ch-lst
mpt1
1
from1
)
lst1
)
lst2 (cons (ch-lst
mpt2
1
from2
)
lst2
)
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
(setq mpt1(get-mindis-pt
(ss-pl-inters
from1
mid1
)
(car mid1)
)
mpt2(get-mindis-pt
(ss-pl-inters
from2
mid2
)
(car mid2)
)
n1(ss-ptc-c mpt1
(cadr mid1)
(car m1)
(> (caddr mid1) 0.0)
)
n2(ss-ptc-c mpt2
(cadr mid2)
(car m2)
(> (caddr mid2) 0.0)
)
from1 (ch-lst mpt1 1 from1)
from2 (ch-lst mpt2 1 from2)
mid1(ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2(ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1(cons mid1 (cons from1 lst1))
lst(cons mid2 (cons from2 lst1))
)
)
)
)
(setq
lst1
(cons mid5 (cons mid3 lst1))
lst2
(cons mid6 (cons mid4 lst2))
)
) ;_end 2.前直后弧
;;;
;;;_3前段弧段，后段直
((and (/= c0 0.0) (= c1 0.0))
(setq mid1 (car mid)
mid2 (cadr mid)
m1 (SS-PTC-ptcR
(car from1)
(cadr from1)
(caddr from1)
)
m2 (SS-PTC-ptcR
(car from2)
(cadr from2)
(caddr from2)
)
m3 (SS-PTC-ptcR
(midpt (car from1) (car from2))
(midpt (cadr from1) (cadr from2))
(/ (+ (caddr from1) (caddr from2)) 2.0)
)
mpt1 (get-mindis-pt (ss-pl-inters from1 mid1) p1)
mpt2 (get-mindis-pt (ss-pl-inters from2 mid2) p1)
)
(cond
((= w02 w11) ;_3.1等宽 这段代码需要改进，思路不清晰,用了开方，容差性差
(setq
mpt1 (pedal_to_line
(car m1)
(car mid1)
(cadr mid1)
)
mpt2 (pedal_to_line
(car m2)
(car mid2)
(cadr mid2)
)
ang(angle (car mid1) (cadr mid1))
)
(if (equal (cadr m1) (distance (car m1) mpt1) 2e-6)
(setq dis1 0.0)
(setq
dis1
(sqrt (- (expt (cadr m1) 2.0)
(expt (distance (car m1) mpt1) 2.0)
)
)
)
)
(if (equal (cadr m2) (distance (car m2) mpt2) 2e-6)
(setq dis2 0.0)
(setq
dis2
(sqrt (- (expt (cadr m2) 2.0)
(expt (distance (car m2) mpt2) 2.0)
)
)
)
)
(setq
mptl1 (polar mpt1 (+ ang pi) dis1)
mptr1 (polar mpt1 ang dis1)
mptl2 (polar mpt2 (+ ang pi) dis2)
mptr2 (polar mpt2 ang dis2)
)
(cond ((> (distance mptl1 (cadr from1))
(distance mptr1 (cadr from1))
)
(setq mpt1 mptr1)
)
((< (distance mptl1 (cadr from1))
(distance mptr1 (cadr from1))
)
(setq mpt1 mptl1)
)
(t
(setq mpt1 (midpt mptl1 mptr1))
)
)
(cond ((> (distance mptl2 (cadr from2))
(distance mptr2 (cadr from2))
)
(setq mpt2 mptr2)
)
((< (distance mptl2 (cadr from2))
(distance mptr2 (cadr from2))
)
(setq mpt2 mptl2)
)
(t
(setq mpt2 (midpt mptl2 mptr2))
)
)
)
((> w02 w11) ;_3.2前宽后窄
(setq mpt1 (inters (cadr from1)
(cadr from2)
(car mid1)
(cadr mid1)
nil
)
mpt2 (inters (cadr from1)
(cadr from2)
(car mid2)
(cadr mid2)
nil
)
)
(if (and mpt1 mpt2)
nil
(setq mpt1 (get-mindis-pt
(ss-pl-inters
from1
mid1
)
(cadr from1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
from2
mid2
)
(cadr from2)
)
)
)
)
((< w02 w11) ;_3.3前窄后宽
(setq mpt1 (get-mindis-pt
(ss-pl-inters
(list (car mid1) (car mid2) 0.0)
from1
)
(cadr from1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
(list (car mid1) (car mid2) 0.0)
from2
)
(cadr from2)
)
) ;_(command "line" (list 0 0) mpt2 "")
(if (and mpt1 mpt2)
nil
(setq mpt1 (get-mindis-pt
(ss-pl-inters
from1
mid1
)
(cadr from1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
from2
mid2
)
(cadr from2)
)
)
)
) ;_3.3
) ;_end cond
(setq
n1 (ss-ptc-c (car from1)
mpt1
(car m1)
(> (caddr from1) 0.0)
)
n2 (ss-ptc-c
(car from2)
mpt2
(car m2)
(> (caddr from2) 0.0)
)
lst1 (cons (ch-lst n1 2 (ch-lst mpt1 1 from1))
lst1
)
lst2 (cons (ch-lst n2 2 (ch-lst mpt2 1 from2))
lst2
)
mid1 (ch-lst mpt1 0 mid1)
mid2 (ch-lst mpt2 0 mid2)
lst1 (cons mid1 lst1) ;_(check-pt (list mpt1 mpt2))
lst2 (cons mid2 lst2)
)
) ;_end 3.前弧后直
;;;
;;;_4.前段弧，后段弧
((and (/= c0 0.0) (/= c1 0.0))
(setq mid1 (car mid)
mid2 (cadr mid)
mid(cddr mid)
mid3 (car mid)
mid4 (cadr mid)
mid(cddr mid)
mid5 (car mid)
mid6 (cadr mid)
m1 (SS-PTC-ptcR
(car from1)
(cadr from1)
(caddr from1)
)
m2 (SS-PTC-ptcR
(car from2)
(cadr from2)
(caddr from2)
)
m3 (SS-PTC-ptcR
(car mid1)
(cadr mid1)
(caddr mid1)
)
m4 (SS-PTC-ptcR
(car mid2)
(cadr mid2)
(caddr mid2)
)
)
(cond ((= w02 w11) ;_4.1等宽
(setq mpt1 (get-mindis-pt
(ss-pl-inters from1 mid1)
(cadr from1)
)
mpt2
(get-mindis-pt
(ss-pl-inters from2 mid2)
(cadr from2)
)
) ;_有一种可能，因为计算误差，引起交点不存在的情况需要处理
(setq n1 (ss-ptc-c (car from1)
mpt1
(car m1)
(> (caddr from1) 0.0)
)
from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
n2 (ss-ptc-c
(car from2)
mpt2
(car m2)
(> (caddr from2) 0.0)
)
from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
n1 (ss-ptc-c mpt1
(cadr mid1)
(car m3)
(> (caddr mid1) 0.0)
)
mid1(ch-lst n1 2 (ch-lst mpt1 0 mid1))
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m4)
(> (caddr mid2) 0.0)
)
mid2(ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1(cons mid1 (cons from1 lst1))
lst2(cons mid2 (cons from2 lst2))
)
)
((> w02 w11) ;_4.2前宽后窄
(setq mpt1 (get-mindis-pt
(ss-pl-inters
(list (cadr from1) (cadr from2) 0.0)
mid1
)
(car mid1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
(list (cadr from1) (cadr from2) 0.0)
mid2
)
(car mid2)
)
)
(if (and mpt1 mpt2)
(progn
(setq n1 (ss-ptc-c mpt1
(cadr mid1)
(car m3)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m4)
(> (caddr mid2) 0.0)
)
)
(setq lst1 (cons from1 lst1)
lst2 (cons from2 lst2)
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
)
;_凸度同号，可能不存在交在宽者法边
(setq mpt1(get-mindis-pt
(ss-pl-inters
from1
mid1
)
(car mid1)
)
mpt2(get-mindis-pt
(ss-pl-inters
from2
mid2
)
(car mid2)
) ;_(check-pt (list mpt1 mpt2))
n1 (ss-ptc-c (car from1)
mpt1
(car m1)
(> (caddr from1) 0.0)
)
n2 (ss-ptc-c (car from2)
mpt2
(car m2)
(> (caddr from2) 0.0)
)
from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
n1 (ss-ptc-c mpt1
(cadr mid1)
(car m3)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m4)
(> (caddr mid2) 0.0)
)
mid1(ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2(ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1(cons from1 lst1)
lst2(cons from2 lst2)
lst1(cons mid1 lst1)
lst2(cons mid2 lst2)
)
) ;_end if
)
((< w02 w11) ;_4.3前窄后宽
(setq mpt1 (get-mindis-pt
(ss-pl-inters
from1
(list (car mid1) (car mid2) 0.0)
)
(cadr from1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
from2
(list (car mid1) (car mid2) 0.0)
)
(cadr from2)
)
)
(if (and mpt1 mpt2)
(setq n1 (ss-ptc-c (car from1)
mpt1
(car m1)
(> (caddr from1) 0.0)
)
n2 (ss-ptc-c (car from2)
mpt2
(car m2)
(> (caddr from2) 0.0)
)
from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
lst1(cons from1 lst1)
lst2(cons from2 lst2)
lst1(cons mid1 lst1)
lst2(cons mid2 lst2)
)
;_凸度同号，可能不存在都交于宽者法边交点
(setq mpt1(get-mindis-pt
(ss-pl-inters
from1
mid1
)
p1
)
mpt2(get-mindis-pt
(ss-pl-inters
from2
mid2
)
p1
)
n1 (ss-ptc-c (car from1)
mpt1
(car m1)
(> (caddr from1) 0.0)
)
n2 (ss-ptc-c (car from2)
mpt2
(car m2)
(> (caddr from2) 0.0)
)
from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
n1 (ss-ptc-c mpt1
(cadr mid1)
(car m3)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m4)
(> (caddr mid2) 0.0)
)
mid1(ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2(ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1(cons from1 lst1)
lst2(cons from2 lst2)
lst1(cons mid1 lst1)
lst2(cons mid2 lst2)
)
) ;_end if
)
)
(setq
lst1
(cons mid5 (cons mid3 lst1))
lst2
(cons mid6 (cons mid4 lst2))
)
) ;_end cond 4
) ;_end cond
) ;_end pro
) ;_end if
) ;_end if pro
) ;_end if
(setq w02 w12
w01 w11
c0c1
b nil
i (1+ i)
)
) ;_end foreach
;;;双环列表创建完毕
;;;
;;;首尾连接处理
(if (= is_close 1)
(progn
(setq from1 (car lst1)
mid1(last lst1)
from2 (car lst2)
mid2(last lst2)
)
(setq mpt1 (get-mindis-pt (ss-pl-inters from1 mid1) (car mid1)) ;_(command "LINE" (list 0 0 0) mpt2 "")
mpt2 (get-mindis-pt (ss-pl-inters from2 mid2) (car mid2))
)
(setq
n1 (if (= (caddr from1) 0.0)
0.0
(ss-ptc-c
(car from1)
mpt1
(car (SS-PTC-ptcR
(car from1)
(cadr from1)
(caddr from1)
)
)
(> (caddr from1) 0.0)
)
)
n2 (if (= (caddr from2) 0.0)
0.0
(ss-ptc-c (car from2)
mpt2
(car (SS-PTC-ptcR
(car from2)
(cadr from2)
(caddr from2)
)
)
(> (caddr from2) 0.0)
)
)
from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
n1 (if (= (caddr mid1) 0.0)
0.0
(ss-ptc-c mpt1
(cadr mid1)
(car (SS-PTC-ptcR
(car mid1)
(cadr mid1)
(caddr mid1)
)
)
(> (caddr mid1) 0.0)
)
)
n2 (if (= (caddr mid2) 0.0)
0.0
(ss-ptc-c mpt2
(cadr mid2)
(car (SS-PTC-ptcR
(car mid2)
(cadr mid2)
(caddr mid2)
)
)
(> (caddr mid2) 0.0)
)
)
mid1(ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2(ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1(ch-lst from1 0 lst1)
lst1(reverse (ch-lst mid1 0 (reverse lst1)))
lst2(ch-lst from2 0 lst2)
lst2(reverse (ch-lst mid2 0 (reverse lst2)))
)
)
)
;;首尾连接处理完毕
;(setvar "osmode" 0) ;_测试用
(setq lst1 (reverse lst1)) ;_(command "line" (list 0 0 0) (nth 0 (nth 2 lst2)) "")
(if (= is_close 0)
(progn
(setq len (length lst1)
i 1
lst nil
)
(foreach a lst1
(if (< i len)
(progn
(setq
lst
(append lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(if (eq (cadr a) (car (nth i lst1)))
nil
(setq lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
(progn
(setq
lst
(append lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(setq
lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
(setq i (1+ i))
)
(setq i 1)
(foreach a lst2
(if (< i len)
(progn
(setq lst
(append
lst
(list (cons 10 (cadr a)) (cons 42 (* -1.0 (caddr a))))
)
)
(if (eq (car a) (cadr (nth i lst2)))
nil
(setq lst
(append lst (list (cons 10 (car a)) (cons 42 0.0)))
)
)
)
(progn
(setq lst (append lst
(list (cons 10 (cadr a))
(cons 42 (* -1.0 (caddr a)))
)
)
)
(setq
lst
(append lst (list (cons 10 (car a)) (cons 42 0.0)))
)
)
)
(setq i (1+ i))
)
(setq lst (append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (/ (length lst) 2))
(cons 70 1)
(cons 43 0.0)
)
lst
)
) ;_(check-pt (ss-assoc 10 lst))
;(entmakex lst)
(setq end (list lst))
)
(progn
(setq len (length lst1)
i 1
lst nil
)
(foreach a lst1
(if (< i len)
(progn
(setq
lst
(append lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(if (eq (cadr a) (cadr (nth i lst1)))
nil
(setq lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
(progn
(setq
lst
(append lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(if (eq (cadr a) (caar lst1))
nil
(setq
lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
)
(setq i (1+ i))
)
(setq lst (append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (/ (length lst) 2))
(cons 70 1)
(cons 43 0.0)
)
lst
)
)
;(entmakex lst)
(setq i1
lst2 (reverse lst2)
end(cons lst end)
lstnil
)
(foreach a lst2
(if (< i len)
(progn
(setq
lst
(append
lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(if (eq (cadr a) (cadr (nth i lst2)))
nil
(setq lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
(progn
(setq
lst
(append lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(if (eq (cadr a) (caar lst2))
nil
(setq
lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
)
(setq i (1+ i))
)
(setq lst (append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (/ (length lst) 2))
(cons 70 1)
(cons 43 0.0)
)
lst
)
)
(setq end (reverse (cons lst end)))
;(entmakex lst)
)
) ;_end if
end
)
主函数源码2:
(defun SS-PL->SBound (pl / ent is_closepl_vetex
b i lst1 lst2 w02c0 p1
p2 w11 w12 c1 bmid mid1
mid2
) ;(setq pl (car (entsel)))
(setq ent (entget pl '("*")))
(setq is_close (rem (cdr (assoc 70 ent)) 2))
(setq pl_vetex nil
b nil
)
(foreach n ent ;_(setq e (assoc 10 ent))
(if (or (= 10 (car n))
(= 40 (car n))
(= 41 (car n))
(= 42 (car n))
) ;_ 结束or
(progn
(setq b (cons (cdr n) b))
(if (= 4 (length b))
(setq pl_vetex (append pl_vetex (list (reverse b)))
bnil
)
)
)
)
)
(setq i 0
b nil
)
(foreach a pl_vetex ;(setq a (nth 1 pl_vetex))
(setq p1(car a)
w11 (cadr a)
w12 (caddr a)
c1(cadddr a)
b (nth (1+ i) pl_vetex)
)
;_(if (= i 1) (princ "pause"))
(if (and (null b) (= is_close 1))
(setq b (car pl_vetex))
)
(if (setq p2 (car b))
(progn
(setq mid(ss-plwk-pts p1 w11 w12 c1 p2)
lst1 nil
lst2 nil
lst3 nil
lst4 nil
)
(repeat (/ (length mid) 2)
(setq
mid1 (car mid)
mid2 (cadr mid)
mid(cddr mid)
lst1 (if (equal (car mid1) (car lst1))
(cons (cadr mid1) lst1)
(cons (cadr mid1) (cons (car mid1) lst1))
)
lst2 (if (equal (car mid2) (car lst2))
(cons (cadr mid2) lst2)
(cons (cadr mid2) (cons (car mid2) lst2))
)
lst3 (cons (caddr mid1) lst3)
lst4 (cons (* -1.0 (caddr mid2)) lst4)
)
)
(draw-pline
(append (reverse lst1) lst2)
0.0
(append (reverse lst3) (append (cons 0.0 lst4) (list 0.0)))
nil
-1
1
)
) ;_end if pro
)
(setq i (1+ i))
) ;_end foreach
;_end if
(princ)
)
配套函数源码3:
;;;配套函数-------------------------------------------------------------;;;
(setq _pi2 1.5707963267948966192313216916395
_2pi 6.283185307179586476925286766559
_1d 0.0174532925199433
)
;;;---------------------------------------------------------------------;;;
;;;获取单段PL线的4个角点和两边凸度
;;;直线段返回4个点((pt11 pt21 n11) (pt12 pt22 n12))
;;;高山流水2010-06-25
;;;(ss-plwk-pts p1 w11 w12 c1 p2)
;;;(setq pt1 p1 w1 w11 w2 12 n c1 pt2 p2)
(defun ss-plwk-pts (pt1 w1 w2n pt2 / ptcR0
ptc0 R0 mpt0ang1 ang2 ang2aang2a/6 dw pt11
pt12 pt21 pt22ptm1 ptm2 ptcr1ptcr2
ptlst lst in1 n2
)
(if (/= n 0.0)
(progn
(setq ptcR0 (SS-PTC-ptcR pt1 pt2 n)
ptc0(car ptcr0)
R0 (cadr ptcr0)
ang1(angle ptc0 pt1)
ang2(angle ptc0 pt2)
ang2a (angle (list 0.0 0.0 0.0) (gsls-XY->AB pt2 ptc0 ang1))
ang2a (if (> n 0)
ang2a
(- ang2a _2pi)
)
ang2a/6 (/ ang2a 6.0)
dw (/ (- w2 w1) 6.0)
)
(setq i 0
ptlst nil)
(repeat 7
(setq pt11 (polar (polar ptc0 (+ ang1 (* i ang2a/6)) R0) (+ ang1 (* i ang2a/6) pi) (/ (+ w1 (* i dw)) 2.0))
pt12 (polar (polar ptc0 (+ ang1 (* i ang2a/6)) R0) (+ ang1 (* i ang2a/6)) (/ (+ w1 (* i dw)) 2.0))
ptlst (cons pt12 (cons pt11 ptlst))
i (1+ i)
)
)
;(check-pt ptlst)
(setq i 0
ptlst (reverse ptlst)
lst nil
)
(repeat 3
(setq pt11 (nth (* i 4) ptlst)
pt12 (nth (1+ (* i 4)) ptlst)
ptm1 (nth (+ (* i 4) 2) ptlst)
ptm2 (nth (+ (* i 4) 3) ptlst)
pt21 (nth (+ (* i 4) 4) ptlst)
pt22 (nth (+ (* i 4) 5) ptlst)
ptcr1 (SS-PT-ptcR pt11 ptm1 pt21)
ptcr2 (ss-pt-ptcr pt12 ptm2 pt22)
n1 (ss-ptc-c pt11 pt21 (car ptcr1) (> n 0))
n2 (ss-ptc-c pt12 pt22 (car ptcr2) (> n 0))
)
(if (> n 0.0)
(setq lst (cons (list pt12 pt22 n2) (cons (list pt11 pt21 n1) lst)))
(setq lst (cons (list pt11 pt21 n1) (cons (list pt12 pt22 n2) lst)))
)
(setq i (1+ i))
)
(setq lst (reverse lst))
)
(progn
(setq ang(angle pt1 pt2)
pt11 (polar pt1 (+ ang _pi2) (/ w1 2.0))
pt12 (polar pt1 (- ang _pi2) (/ w1 2.0))
pt21 (polar pt2 (+ ang _pi2) (/ w2 2.0))
pt22 (polar pt2 (- ang _pi2) (/ w2 2.0))
)
(list (list pt11 pt21 0.0) (list pt12 pt22 0.0))
)
)
)
;;;---------------------------------------------------------------------;;;
;;;已知圆弧起点、终点和凸度，求圆心和半径
;;;高山流水2010-06-25
;;;(SS-PTC-ptcR '(764814.0 -1.11779e+006 0.0) '(734523.0 -1.11239e+006) -0.722053)
(defun SS-PTC-ptcR (pt1 pt2 convexity / ang mpt a b ptc R)
(setq ang (angle pt1 pt2)
mpt (midpt pt1 pt2)
b (distance pt1 mpt)
a (* b
(/ (sin (- _pi2 (* 2.0 (atan convexity))))
(cos (- _pi2 (* 2.0 (atan convexity))))
)
)
ptc (polar mpt (+ ang _pi2) a)
R (sqrt (+ (* a a) (* b b)))
)
(list ptc R)
)
;;;---------------------------------------------------------------------;;;
;;;已知圆弧上的3点，求圆心和半径
;;;高山流水2010-06-25
(defun SS-PT-ptcR (pt1 mpt pt2 / mpt1 mpt2 mpt11 mpt22 ptc R)
(setq mpt1(midpt pt1 mpt)
mpt2(midpt mpt pt2)
mpt11 (polar mpt1 (+ (angle pt1 mpt) _pi2) 1000.0)
mpt22 (polar mpt2 (+ (angle mpt pt2) _pi2) 1000.0)
ptc (inters mpt1 mpt11 mpt2 mpt22 nil)
R (distance ptc pt1)
);_(check-pt (list pt1 mpt pt2))
(list ptc R)
)
;;;---------------------------------------------------------------------;;;
;;;已知圆弧的端点pt1->pt2,圆心ptc,求凸度
;;;高山流水2010-06-26
;;;
(defun ss-ptc-c (pt1 pt2 ptc is_nsz / ang1 pt2a ang2)
(setq ang1 (angle ptc pt1)
pt2a (gsls-XY->AB pt2 ptc ang1)
ang2 (angle (list 0.0 0.0 0.0) pt2a)
)
(if is_nsz
nil
(setq ang2 (- ang2 _2pi))
)
(/ (sin (/ ang2 4.0)) (cos (/ ang2 4.0)))
)
;;;---------------------------------------------------------------------;;;
;;;将点XY坐标换算为AB坐标，AB坐标的原点为PT0，转角为R0
;;;A=(X-X0)cosR0+(Y-Y0)sinR0
;;;B=(Y-Y0)cosR0-(X-X0)sinR0
(defun gsls-XY->AB (pt pt0 ANG / A B)
(setq A (+ (* (- (car pt) (car pt0)) (cos ANG))
(* (- (cadr pt) (cadr pt0)) (sin ANG))
)
B (- (* (- (cadr pt) (cadr pt0)) (cos ANG))
(* (- (car pt) (car pt0)) (sin ANG))
)
)
(list A B 0.0)
)
;;;---------------------------------------------------------------------;;;
;;;求两点中点
(defun midpt (pta ptb)
(mapcar (function (lambda (x y)
(/ (+ x y) 2.0)
)
)
pta
ptb
)
)
;;;---------------------------------------------------------------------;;;
;;;求直线、圆弧交点集,点凸版
;;;(ss-pl-inters '((713708.0 -563492.0) (717691.0 -570078.0) 0.0) '((715257.0 -566053.0) (720145.0 -553354.0) 0.280634))
(defun ss-pl-inters (mid1 mid2 / intersections)
(setq pt11 (car mid1)
pt12 (cadr mid1)
n1 (caddr mid1)
pt21 (car mid2)
pt22 (cadr mid2)
n2 (caddr mid2)
intersections nil
)
(cond ((= n1 n2 0.0) ;_直线交直线
(list (inters pt11 pt12 pt21 pt22 nil))
)
((and (= n1 0.0) (/= n2 0.0)) ;_直线交圆弧
(setq ptcr2 (SS-PTC-ptcR pt21 pt22 n2))
(L_INT_C pt11 pt12 (car ptcr2) (cadr ptcr2))
)
((and (/= n1 0.0) (= n2 0.0)) ;_圆弧交直线
(setq ptcr1 (SS-PTC-ptcR pt11 pt12 n1))
(L_INT_C pt21 pt22 (car ptcr1) (cadr ptcr1))
)
((and (/= n1 0.0) (/= n2 0.0)) ;_圆弧交圆弧
(setq ptcr1 (SS-PTC-ptcR pt11 pt12 n1)
ptcr2 (SS-PTC-ptcR pt21 pt22 n2)
)
(c_int_c (car ptcr1) (cadr ptcr1) (car ptcr2) (cadr ptcr2))
)
)
)
;;;---------------------------------------------------------------------;;;
;;;此函数2010.07.06改版,注意其他程序
(defun gsls-ang-trans (ang)
(while (> ang pi)
(setq ang (- ang pi))
)
(while (< ang 0.0)
(setq ang (+ ang pi))
)
ang
)
;;;---------------------------------------------------------------------;;;
;;;用到WK函数
;___________________直线与圆交点函数,输入值直线端点1,端点2,圆心,半径.返回值交点表
(defun L_INT_C (l_end1 l_end2 c_cen c_rad / pedal dist_cen_l int1 int2
ints)
(setq pedal (pedal_to_line c_cen l_end1 l_end2)
dist_cen_l (distance pedal c_cen))
(cond
((equal c_rad dist_cen_l min_num) (setq ints (list pedal)))
((> c_rad dist_cen_l)
(progn
(setq int1
(polar pedal
(angle l_end1 l_end2)
(sqrt (- (* c_rad c_rad) (* dist_cen_l dist_cen_l)))
)
)
(setq int2
(polar pedal
(+ pi (angle l_end1 l_end2))
(sqrt (- (* c_rad c_rad) (* dist_cen_l dist_cen_l)))
)
)
(setq ints (list int1 int2))
)
)
)
ints
)
;;;点到直线的垂足坐标
(defun pedal_to_line (pt pt1 pt2)
(inters
pt
(polar pt (+ (/ pi 2) (angle pt1 pt2)) 1000)
pt1
pt2
nil
)
)
;_精度设置_________________________________________________
(setq min_num 1e-7)
;___________________圆与圆交点函数,输入值圆心1,半径1,圆心2,半径2.返回值交点表
(defun c_int_c (c1_cen c1_rad c2_cen c2_rad / ints c1c2_dis dd ee)
(setq c1c2_dis (distance c1_cen c2_cen))
(cond
((equal c1c2_dis (+ c1_rad c2_rad) min_num)
(setq ints (list (polar c1_cen (angle c1_cen c2_cen) c1_rad)))
)
((equal c1c2_dis (abs (- c1_rad c2_rad)) min_num)
(if (minusp (- c1_rad c2_rad))
(setq ints (list (polar c2_cen (angle c2_cen c1_cen) c2_rad)))
(setq ints (list (polar c1_cen (angle c1_cen c2_cen) c1_rad)))
)
)
((and (> c1c2_dis (abs (- c1_rad c2_rad)))
(< c1c2_dis (+ c1_rad c2_rad))
)
(progn
(setq dd (/ (- (+ (* c1c2_dis c1c2_dis) (* c1_rad c1_rad))
(* c2_rad c2_rad)
)
(* 2 c1c2_dis)
)
)
(setq ee (sqrt (- (* c1_rad c1_rad) (* dd dd))))
(setq
ints (list (polar (polar c1_cen (angle c1_cen c2_cen) dd)
(+ (angle c1_cen c2_cen) (/ pi 2))
ee
)
)
)
(setq ints
(append
ints
(list (polar (polar c1_cen (angle c1_cen c2_cen) dd)
(- (angle c1_cen c2_cen) (/ pi 2))
ee
)
)
)
)
)
)
)
ints
)
;;;________________________________________________;;;
;;;---------------------------------------------------------------------;;;
;;;其他函数
;;;获取点集ptlst中与点pt距离最近的点
(defun get-mindis-pt (ptlst pt)
(car
(vl-sort ptlst
(function (lambda (e1 e2)
(< (distance e1 pt) (distance e2 pt))
)
)
)
)
)
;;;---------------------------------------------------------------------;;;
;;;参考qj_chen表项替代函数改进
;;;表项替换，支持2重表，当指定i为list如(3 1)时，替换第3个子表中的第1个元素
(defun ch-lst (new i lst / j len fst mid)
(if (/= (type i) 'list)
(cond
((minusp i)
lst
)
((> i (setq len (length lst)))
lst
)
((> i (/ len 2))
(reverse (ch-lst new (1- (- len i)) (reverse lst)))
)
(t
(append
(progn
(setq fst nil)
(repeat (rem i 4)
(setq fst (cons (car lst) fst)
lst (cdr lst)
)
)
(repeat (/ i 4)
(setq fst (cons (cadddr lst)
(cons (caddr lst)
(cons
(cadr lst)
(cons
(car lst)
fst
)
)
)
)
lst (cddddr lst)
)
)
(reverse fst)
)
(list new)
(cdr lst)
)
)
)
(progn
(setq j (cadr i)
i (car i)
)
(if j
(progn
(setq mid (nth i lst))
(setq mid (ch-lst new j mid))
(ch-lst mid i lst)
)
(ch-lst new i lst)
)
)
)
)
;;;---------------------------------------------------------------------;;;
;;;用到 吴所不及 函数
;;;转换选择集为表
(defun wjm_ss2lst (ss / i e lst)
(if (= (type ss) 'PICKSET)
(progn
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(if (= (type e) 'ENAME) (setq lst (cons e lst)) nil)
)
lst
)
nil
)
)
如有问题请采用下列代码将问题图元表贴出
;;;实体与字符串互换
(defun obj->str (ent / relst mid ent)
(setq relst (list -1 330 330 5 100 100 102 102 410))
(setq mid (print ent))
(foreach num relst
(progn
(setq mid (vl-remove (assoc num mid) mid))
)
)
(vl-prin1-to-string mid)
)
(defun c:tt ()
(obj->str (entget (car (entsel)) '("*")))
(princ)
)
<p></p>
<p></p> 习惯性的收藏一下，，，，，，， 收藏 支持一下！ <p>很不错！支持楼主的无私！ppl1命令缺少<font face="Verdana">DRAW-PLINE</font>函数，请楼主补一下！</p> “高山”应该继续研究下去…… 应6楼要求，把缺漏函数补上
;;--------------------------------------------------------------------------------------;;;
;;;draw-pline ;;;
;;;--------------------------------------------------------------------------------------;;;
;;;
;;;function: to make a polyline by code and return ename
;;;
;;;Variants:
;;;pl_list: the points list offered by order
;;;width : 0.0 or num, or a list like ((0.0 0.0) (0.0 20) (20 0.0)...),if nil it will getvar "plinewid" ,
;;; if it's length noteq d90 then wid41 and wid42 equal to 0.0 .
;;;d42_lst: 0.0 or num, or nil, if nil or it's length noteq d90 then d42 equal to 0.0 .
;;;
;;;lay_pl: layername, if nil it will getvar "CLAYER"
;;;
;;;color : color number, if it's -1 then getvar "COLOR" ellse set it by the given color number
;;;
;;;Prompt:
;;;If width list or d42_lst list is Exist , it's order must be same to the pl_list,
;;; otherwise it will take out a wrong polyline .
;;;
;;;Written By WJM and GSLS(SS),2010.06.30
;;;
(defun draw-pline
(pl_list width d42_lst lay_plcolor d70
/ d90 i wid d42 wid40
wid41 en000 pb
) ;_加入宽度列表和凸度列表
(setq d90 (length pl_list)
pb'()
i 0
)
(cond ((and (listp width)
(listp d42_lst)
(= (length width) (length d42_lst) d90)
)
(foreach pt pl_list
(setq wid (nth i width)
d42 (nth i d42_lst)
wid40 (car wid)
wid41 (cadr wid)
pb (append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 d42)
)
)
i (1+ i)
)
)
)
((and (or (numberp width) (null width))
(listp d42_lst)
(= (length d42_lst) d90)
)
(if (null width)
(setq wid40 (getvar "plinewid")
wid41 (getvar "plinewid")
)
(setq wid40 width
wid41 width
)
)
(foreach pt pl_list
(setq d42 (nth i d42_lst)
pb(append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 d42)
)
)
i (1+ i)
)
)
)
((and (listp width)
(= (length width) d90)
(or (null d42_lst) (numberp d42_lst))
)
(if (null d42_lst)
(setq d42 0.0)
(setq d42 d42_lst)
)
(foreach pt pl_list
(setq wid (nth i width)
wid40 (car wid)
wid41 (cadr wid)
pb (append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 d42)
)
)
i (1+ i)
)
)
)
(t
(if (numberp width)
(setq wid40 width
wid41 width
)
(setq wid40 0.0
wid41 0.0
)
)
(foreach pt pl_list
(setq pb (append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 0.0)
)
)
)
)
)
)
(setq en000 (append (list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 8
(if (and lay_pl (/= lay_pl ""))
lay_pl
(getvar "CLAYER")
)
) ;_这里稍微改动了下
(cons 100 "AcDbPolyline")
(cons 90 d90)
(cons 70 d70)
)
pb
)
)
(if (and color (/= -1 color))
(setq en000 (append en000 (list (cons 62 color))))
)
(if (= nil (entmake en000))
(princ "\n制造 LWPL 制造失败.")
)
(entlast)
)
谢谢院长的鼓励，最近比较忙，得空了，结合ACAD2011看看，有没有办法简化些 <p>有意思，可能也很有意义。</p>
<p>支持</p>
<p> </p>
页:
[1]
2