999999 发表于 2021-5-24 09:14:23

(求助)多段线自动延伸

以下代码是chinawhy817大神写的
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=98171&highlight=%D1%D3%C9%EC

希望有路过的大神有空且知道的话，可以帮一下小弟实现以下功能：
1.输入命令
2.选择（单选或框选）外框或者全部选择
3.框内多段线延伸到外框（结束）

源码如下：
功能为：框选直线延伸
(defun Dk:PtRelateLine (Pt1 Pt2 Pt3 / Dis12 Dis13 Dis23)
    (cond ((= (rtos (setq Dis12 (distance Pt1 Pt2)) 2 5) "0.00000") 1)
          ((= (rtos (setq Dis13 (distance Pt1 Pt3)) 2 5) "0.00000") 2)
          ((= (rtos (+ Dis12 Dis13) 2 5) (rtos (setq Dis23 (distance Pt2 Pt3)) 2 5)) 4)
          ((= (rtos (+ Dis13 Dis23) 2 5) (rtos Dis12 2 5)) 8)
          ((= (rtos (+ Dis12 Dis23) 2 5) (rtos Dis13 2 5)) 16)
          (t 32)))

(defun C:EXT (/ n s j dxf_a a10 a11 k data1 data2 dxf_b b10 b11 insect d1 d2 index)
(setq n (sslength (setq s (ssget '((0 . "LINE"))))))
(setq j -1)
(while (< (setq j (1+ j)) n)   
    (setq dxf_a (entget (ssname s j)))
    (setq a10 (cdr (assoc 10 dxf_a)))
    (setq a11 (cdr (assoc 11 dxf_a)))
    (setq k -1data1 (list) data2 (list))
    (while (< (setq k (1+ k)) n)      
      (setq dxf_b (entget (ssname s k)))
      (if (/= (cdr (assoc 5 dxf_a)) (cdr (assoc 5 dxf_b)))
      (progn
          (setq b10 (cdr (assoc 10 dxf_b)) b11 (cdr (assoc 11 dxf_b)))
          (if (null (inters a10 a11 b10 b11))
            (progn
            (if (setq insect (inters a10 a11 b10 b11 nil))
                (progn                  
                  (if (/= 0 (logand 7 (Dk:PtRelateLine insect b10 b11)))
                  (progn                     
                      (cond ((> (setq d1 (distance insect a10))(setq d2 (distance insect a11)))
                           (setq data1 (append data1 (list (list d2 insect 11)))))
                            ((setq data2 (append data2 (list (list d1 insect 10))))))
                      ))
                  )) ;end if (setq insect (inters a10 a11 b10 b11 nil))
            )) ;end if (null (inters a10 a11 b10 b11))
          )) ;end if (/= (cdr (assoc 5 dxf_a)) (cdr (assoc 5 dxf_b)))
      ) ;end while

    (if (> (length data1) 0)
      (progn
      (setq data1 (vl-sort data1 '(lambda (X Y) (< (car X)(car Y)))))
      (setq index (last (car data1)))      
      (entmod (setq dxf_a (subst (cons index (cadr (car data1)))(assoc index dxf_a) dxf_a)))
      )
      )

    (if (> (length data2) 0)
      (progn
      (setq data2 (vl-sort data2 '(lambda (X Y) (< (car X)(car Y)))))
      (setq index (last (car data2)))      
      (entmod (subst (cons index (cadr (car data2)))(assoc index dxf_a) dxf_a))
      )
      )
    ) ;end while
(princ))


start4444 发表于 2021-5-24 09:14:24

直接选矩形外框

999999 发表于 2021-5-25 12:03:25

start4444 发表于 2021-5-25 10:25
直接选矩形外框

大神历害，，

999999 发表于 2021-5-25 12:03:56

start4444 发表于 2021-5-25 10:25
直接选矩形外框

谢谢大神的热心帮助
页: [1]
查看完整版本: (求助)多段线自动延伸