小毛草 发表于 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/forum.php?mod=viewthread&tid=225142&extra=page%3D1
[*]感谢原作者，找了好久的，海龙软件少了这个东西就不好用了！

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

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

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

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

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

谢谢分享，好用
页: [1]
查看完整版本: 尺寸定点伸缩！