直线上最近的点

LISP2LEARN · 发表于 2022-7-6 07:58:39

我前阵子从李那里得到了这个代码，它工作得很好，但我需要做一些调整，我不知道怎么做。我可以理解代码，但修改它对我来说是一项艰巨的任务。我所需要的是：如果块名为“Block1”，将线放在“Layer1”的层上，“Block2”到“Layer2”层上。
再次感谢。

copy

;;;by lee-mac ;;nearest point on a line
(defun c:test ( / d1 d2 el en in l1 l2 p2 p3 ss )
   (if (setq ss (ssget '((0 . "INSERT,LINE"))))
       (progn
           (repeat (setq in (sslength ss))
               (setq en (ssname ss (setq in (1- in)))
                     el (entget en)
               )
               (if (eq "LINE" (cdr (assoc 0 el)))
                   (setq l1 (cons en l1))
                   (setq l2 (cons (trans (cdr (assoc 10 el)) en 0) l2))
               )
           )
           (foreach p1 l2
               (setq p2 (vlax-curve-getclosestpointto (car l1) p1)
                     d1 (distance p1 p2)
               )
               (foreach en (cdr l1)
                   (setq p3 (vlax-curve-getclosestpointto en p1)
                         d2 (distance p1 p3)
                   )
                   (if (< d2 d1) (setq d1 d2 p2 p3))
               )
               (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
           )
       )
   )
   (princ)
)
(vl-load-com) (princ)

BIGAL · 发表于 2022-7-6 08:17:05

不精确，但给出了需要“if a block”并使用assoc 2=块名的想法

copy

(if (eq "LINE" (cdr (assoc 0 el)))
                   (setq l1 (cons en l1))
(if (eq "INSERT" (cdr (assoc 0 el)))
                   (setq blockname (cdr (assoc 2 el)))
then you need to find out block "2" so can do a (setvar "clayer" "layer2") 
)
You need a end of text as numbers 01 etc lisp do it as a defun in main code I need this also Lee I think has a routine for this.

Lee Mac · 发表于 2022-7-6 08:24:43

稍微调整一下：

copy

;; Nearest point on a line  -  Lee Mac
(defun c:test ( / d1 d2 el en in l1 l2 la p2 p3 ss )
   (if (setq ss (ssget '((0 . "INSERT,LINE"))))
       (progn
           (repeat (setq in (sslength ss))
               (setq en (ssname ss (setq in (1- in)))
                     el (entget en)
               )
               (if (eq "LINE" (cdr (assoc 0 el)))
                   (setq l1 (cons en l1))
                   (setq l2 (cons (list (trans (cdr (assoc 10 el)) en 0) (cdr (assoc 2 el))) l2))
               )
           )
           (foreach p1 l2
               (setq la (cadr p1)
                     p1 (car  p1)
                     p2 (vlax-curve-getclosestpointto (car l1) p1)
                     d1 (distance p1 p2)
               )
               (foreach en (cdr l1)
                   (setq p3 (vlax-curve-getclosestpointto en p1)
                         d2 (distance p1 p3)
                   )
                   (if (< d2 d1) (setq d1 d2 p2 p3))
               )
               (entmake
                   (list
                      '(0 . "LINE")
                       (cons 8 (vl-string-subst "Layer" "Block" la))
                       (cons 10 p1)
                       (cons 11 p2)
                   )
               )
           )
       )
   )
   (princ)
)
(vl-load-com) (princ)