谁帮我完善一下程序
以下是明经社区的朋友帮我改过的一个程序，能动态伸缩line和PL线，一直在用，很方便但是其中的不足之处随着使用的增多越发觉得有完善的必要：
不足之处：1.作用于多义线时无捕捉 2.不能多选
盼高手相助
;;;-------------------------------------------------------------------------------------------------------------------
;;; ★DB_DYNLSLINE线动态拉伸（通杀line和pline）
;;; 不足之处：1.作用于多义线时无捕捉 2.不能多选
;;;-------------------------------------------------------------------------------------------------------------------
(defun c:DB_DYNLSLINE ( / old_cmd +- ang ang0 dis
e ent epar gptgpt1
grr i ind mparn
o par ptpt1
pt2 ptn pto spar
vlapto ss tpar
times
)
;;;(mini_start nil)
;;;(princ "\n不封闭的多义线动态拉伸 carrot1983 2008/11/25")
(setq en (entsel))
(if (= "LINE" (cdr (assoc 0 (entget (car en)))))
(COMMAND "LENGTHEN" "DY" en)
(if (and (setq pt en)
(setq e (car pt)
pt (cadr pt)
o (vlax-ename->vla-object e)
)
(= (vlax-get-property o 'ObjectName) "AcDbPolyline")
(not (vlax-curve-isclosed o))
)
(progn
(setq pt (vlax-curve-getClosestPointTo o (trans pt 1 0))
spar (vlax-curve-getstartparam e)
epar (vlax-curve-getendparam e)
tpar (- epar spar)
par (vlax-curve-getparamatpoint o pt)
ang0 (vlax-curve-getfirstderiv o par)
ang0 (angle '(0 0) (list (car ang0) (cadr ang0)))
ind (fix par)
mpar (+ ind 0.5)
)
(while (and (setq grr (grread t 4 0))
(member (car grr) (list 2 5 25))
)
(setq pt1 (vlax-curve-getpointatparam e ind)
pt2 (vlax-curve-getpointatparam e (+ ind 1))
)
(if (< par mpar)
(setq i 0 +- - times (+ ind 1))
(setq i pt1 pt1 pt2 pt2 i i 1 +- + times (fix (- tpar ind)))
)
(setq gpt (cadr grr)
gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt))
pto (inters pt1 pt2 gpt gpt1 nil)
dis (distance pt1 pto)
ang (angle pt1 pto)
)
(repeat times
(setq n (+- ind i)
i (1+ i)
ptn (vlax-safearray->list (vlax-variant-value (vla-get-coordinate o n)))
vlapto (vlax-make-safearray vlax-vbdouble '(0 . 1))
)
(vlax-safearray-fill vlapto (polar ptn ang dis))
(vla-put-coordinate o n vlapto)
)
)
)
))
;;;(mai_end)
)
本帖最后由 wudechao 于 2013-11-22 02:47 编辑
(defun c:DB_DYNLSLINE(/ *error* oos oor en point ent dxf p1 p2 dis1 dis2 n pt per-pt ptold cen rad angle0 angle1 angle2 angle3 maj rat
r1 r2 a b ent2 ratio spar epar tpar par ang0 ind mpar grr pt1 pt2 i +- times gpt gpt1 ptmid pt0 ptn dis ang
vlapto
)
(vl-load-com)
(setvar "cmdecho" 0)
(defun *error* (msg)
(if oos
(setvar "osmode" oos)
)
(if oor
(setvar "orthomode" oor)
)
)
(setq oor (getvar "orthomode")
oos (getvar "osmode")
)
(while (setq en (entsel "\n选择要修改的对象或 [放弃(U)]:"))
(if (= "LINE" (cdr (assoc 0 (entget (car en)))))
(progn
(prompt (strcat "\n指定新端点:"))
(setq point (osnap (cadr en) "nea"))
(setq ent (car en))
(setq dxf (entget ent))
(setq p1 (cdr (assoc 10 dxf))
p2 (cdr (assoc 11 dxf))
)
(setq dis1 (distance p1 point)
dis2 (distance p2 point)
)
(while (/= 3 (car (setq n (grread t 4 3))))
(setq pt (cadr n))
(setq per-pt (vlax-curve-getclosestpointto ent pt t))
(if ptold
(grdraw point ptold 0)
)
(grdraw point pt 7)
(setq ptold pt)
(if (>= dis1 dis2)
(progn
(setq dxf (subst
(cons 11 per-pt)
(assoc 11 dxf)
dxf
)
)
)
(progn
(setq dxf (subst
(cons 10 per-pt)
(assoc 10 dxf)
dxf
)
)
)
)
(entmod dxf)
)
(grdraw point ptold 0)
)
)
(if (= "ARC" (cdr (assoc 0 (entget (car en)))))
(progn
(prompt (strcat "\n指定新端点:"))
(setq point (osnap (cadr en) "nea"))
(setq ent (car en))
(setq dxf (entget ent))
(setq cen (cdr (assoc 10 dxf))
rad (cdr (assoc 40 dxf))
angle1 (cdr (assoc 50 dxf))
angle2 (cdr (assoc 51 dxf))
p1 (polar cen angle1 rad)
p2 (polar cen angle2 rad)
dis1 (distance p1 point)
dis2 (distance p2 point)
)
(while (/= 3 (car (setq n (grread t 4 3))))
(setq pt (cadr n))
(setq per-pt (vlax-curve-getclosestpointto ent pt t)
per-pt (angle cen per-pt)
)
(if ptold
(grdraw point ptold 0)
)
(grdraw point pt 7)
(setq ptold pt)
(if (>= dis1 dis2)
(progn
(setq dxf (subst
(cons 51 per-pt)
(assoc 51 dxf)
dxf
)
)
)
(progn
(setq dxf (subst
(cons 50 per-pt)
(assoc 50 dxf)
dxf
)
)
)
)
(entmod dxf)
)
(grdraw point ptold 0)
)
)
(if (= "ELLIPSE" (cdr (assoc 0 (entget (car en)))))
(progn
(prompt (strcat "\n指定新端点:"))
(setq point (osnap (cadr en) "nea"))
(setq ent (car en))
(setq dxf (entget ent))
(setq cen (cdr (assoc 10 dxf))
maj (cdr (assoc 11 dxf))
rat (cdr (assoc 40 dxf))
a (distance (quote (0 0)) maj)
b (* a rat)
angle0 (angle (quote (0 0)) maj)
angle1 (cdr (assoc 41 dxf))
angle2 (cdr (assoc 42 dxf))
)
(setq r1 (/ (* a b) (sqrt (+ (expt (* b (cos angle1)) 2) (expt (* a (sin angle1)) 2)))))
(setq r2 (/ (* a b) (sqrt (+ (expt (* b (cos angle2)) 2) (expt (* a (sin angle2)) 2)))))
(setq angle1 (+ angle1 angle0)
angle2 (+ angle2 angle0)
dis1 (distance (polar cen angle1 r1) point)
dis2 (distance (polar cen angle2 r2) point)
)
(while (/= 3 (car (setq n (grread t 4 3))))
(setq pt (cadr n))
(setq per-pt (vlax-curve-getclosestpointto ent pt t)
angle3 (angle cen per-pt)
)
(if (< angle3 angle1)
(setq angle3 (+ angle3 (* 2 pi)))
)
(setq per-pt (- angle3 angle0))
(if ptold
(grdraw point ptold 0)
)
(grdraw point pt 7)
(setq ptold pt)
(if (>= dis1 dis2)
(progn
(setq dxf (subst
(cons 42 per-pt)
(assoc 42 dxf)
dxf
)
)
)
(progn
(setq dxf (subst
(cons 41 per-pt)
(assoc 41 dxf)
dxf
)
)
)
)
(entmod dxf)
)
(grdraw point ptold 0)
)
)
(if (= "LWPOLYLINE" (cdr (assoc 0 (entget (car en)))))
(progn
(prompt (strcat "\n指定新端点:"))
(setq pt en)
(setq e (car pt)
pt0 (cadr pt)
ent2 (vlax-ename->vla-object e)
)
(if (and
(= (vlax-get-property ent2 (quote objectname)) "AcDbPolyline")
(not (vlax-curve-isclosed ent2))
)
(progn
(setq pt0 (vlax-curve-getclosestpointto ent2 (trans pt0 1 0))
spar (vlax-curve-getstartparam e)
epar (vlax-curve-getendparam e)
tpar (- epar spar)
par (vlax-curve-getparamatpoint ent2 pt0)
ang0 (vlax-curve-getfirstderiv ent2 par)
ang0 (angle (quote (0 0)) (list (car ang0) (cadr ang0)))
ind (fix par)
mpar (+ ind 0.5)
)
(while (and
(setq grr (grread t 4 0))
(member (car grr) (list 2 5 25))
)
(setq pt1 (vlax-curve-getpointatparam e ind)
pt2 (vlax-curve-getpointatparam e (+ ind 1))
)
(if (< par mpar)
(setq i 0
+- -
times (+ ind 1)
)
(setq i pt1
pt1 pt2
pt2 i
i 1
+- +
times (fix (- tpar ind))
)
)
(setq gpt (cadr grr)
gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt))
ptmid (inters
pt1
pt2
gpt
gpt1
nil
)
dis (distance pt1 ptmid)
ang (angle pt1 ptmid)
)
(if ptold
(grdraw pt0 ptold 0)
)
(grdraw pt0 gpt 7)
(setq ptold gpt)
(repeat times
(setq n (+- ind i)
i (1+ i)
ptn (vlax-safearray->list (vlax-variant-value (vla-get-coordinate ent2 n)))
vlapto (vlax-make-safearray vlax-vbdouble (quote (0 . 1)))
)
(vlax-safearray-fill vlapto (polar ptn ang dis))
(vla-put-coordinate ent2 n vlapto)
)
)
(grdraw pt0 ptold 0)
)
)
)
)
)
(setvar "orthomode" oor)
(setvar "osmode" oos)
(setvar "cmdecho" 1)
(princ)
) 东西部错，不比像拉伸那样选择起来费劲 顶到高手出招为止 ;; 动态边线
xyp1964 发表于 2012-12-1 19:45 static/image/common/back.gif
;; 动态边线
院长，能做成对单根PL线的吗？ 做个记号，留着 看起来不错 还是不行啊，多义线无捕捉点
页:
[1]