尺寸定点伸缩！

小毛草 · 发表于 2019-4-18 20:42:46

(vl-load-com)
(defun c:dimension-ExtLinePoint-algin_beyondutmost (/ a dividepoint
extline1point1
extline1point2
extline2point1
extline2point2 j n
perpoint ss sslen
)
(if (and
(setq ss (ssget '((0 . "DIMENSION"))))
(> (setq sslen (sslength ss))
1
)
)
(progn
(setq dividepoint (getpoint "\nPick the alginment point:"))
(setq n 0)
(while (< n (1- sslen))
(setq j (1+ n))
(while (< j sslen)
(setq ExtLine1Point1 (cdr (assoc 13 (entget (ssname ss n))))
ExtLine2Point1 (cdr (assoc 14 (entget (ssname ss n))))
ExtLine1Point2 (cdr (assoc 13 (entget (ssname ss j))))
ExtLine2Point2 (cdr (assoc 14 (entget (ssname ss j))))
)
(if (< (distance ExtLine1Point1 ExtLine1Point2) 0.1)
(progn
(setq a (mapcar
'-
ExtLine1Point1
ExtLine2Point1
)
)
(setq perpoint (inters
(mapcar
'+
(list (- (cadr a)) (car a) (caddr a))
dividepoint
)
dividepoint
ExtLine1Point1
ExtLine2Point1
nil
)
)
(entmod (subst
(cons 13 perpoint)
(assoc 13 (entget (ssname ss n)))
(entget (ssname ss n))
)
)
(entmod (subst
(cons 13 perpoint)
(assoc 13 (entget (ssname ss j)))
(entget (ssname ss j))
)
)
)
)
(if (< (distance ExtLine1Point1 ExtLine2Point2) 0.1)
(progn
(setq a (mapcar
'-
ExtLine1Point1
ExtLine2Point1
)
)
(setq perpoint (inters
(mapcar
'+
(list (- (cadr a)) (car a) (caddr a))
dividepoint
)
dividepoint
ExtLine1Point1
ExtLine2Point1
nil
)
)
(entmod (subst
(cons 13 perpoint)
(assoc 13 (entget (ssname ss n)))
(entget (ssname ss n))
)
)
(entmod (subst
(cons 14 perpoint)
(assoc 14 (entget (ssname ss j)))
(entget (ssname ss j))
)
)
)
)
(if (< (distance ExtLine2Point1 ExtLine1Point2) 0.1)
(progn
(setq a (mapcar
'-
ExtLine1Point1
ExtLine2Point1
)
)
(setq perpoint (inters
(mapcar
'+
(list (- (cadr a)) (car a) (caddr a))
dividepoint
)
dividepoint
ExtLine1Point1
ExtLine2Point1
nil
)
)
(entmod (subst
(cons 14 perpoint)
(assoc 14 (entget (ssname ss n)))
(entget (ssname ss n))
)
)
(entmod (subst
(cons 13 perpoint)
(assoc 13 (entget (ssname ss j)))
(entget (ssname ss j))
)
)
)
)
(if (< (distance ExtLine2Point1 ExtLine2Point2) 0.1)
(progn
(setq a (mapcar
'-
ExtLine1Point1
ExtLine2Point1
)
)
(setq perpoint (inters
(mapcar
'+
(list (- (cadr a)) (car a) (caddr a))
dividepoint
)
dividepoint
ExtLine1Point1
ExtLine2Point1
nil
)
)
(entmod (subst
(cons 14 perpoint)
(assoc 14 (entget (ssname ss n)))
(entget (ssname ss n))
)
)
(entmod (subst
(cons 14 perpoint)
(assoc 14 (entget (ssname ss j)))
(entget (ssname ss j))
)
)
)
)
(setq j (1+ j))
)
(setq n (1+ n))
)
)
(progn
(setq dividepoint (getpoint "\nPick the alginment point:"))
(setq ExtLine1Point1 (cdr (assoc 13 (entget (ssname ss 0))))
ExtLine2Point1 (cdr (assoc 14 (entget (ssname ss 0))))
)
(setq a (mapcar
'-
ExtLine1Point1
ExtLine2Point1
)
)
(setq perpoint (inters
(mapcar
'+
(list (- (cadr a)) (car a) (caddr a))
dividepoint
)
dividepoint
ExtLine1Point1
ExtLine2Point1
nil
)
)
(if (<= (distance ExtLine1Point1 perpoint) (distance ExtLine2Point1
perpoint
)
)
(entmod (subst
(cons 13 perpoint)
(assoc 13 (entget (ssname ss 0)))
(entget (ssname ss 0))
)
)
(entmod (subst
(cons 14 perpoint)
(assoc 14 (entget (ssname ss 0)))
(entget (ssname ss 0))
)
)
)
)
)
(princ)
)
出处：http://www.tigerspace.net/bbs/fo ... &extra=page%3D1
感谢原作者，找了好久的，海龙软件少了这个东西就不好用了！

yoyoho · 发表于 2019-4-19 09:28:57

谢谢! 小毛草分享程序!!!!!

zmzk · 发表于 2019-12-10 19:48:02

请问怎么用啊？怎么唤起这命令？？

伊偭 · 发表于 2024-9-8 18:21:52

谢谢分享，好用

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

[资源] 尺寸定点伸缩！