能不能批量实现，按单独各自垂线移动物体

lidaxiu

能不能批量实理，先以叉字交点画白线的垂线，然后把叉交点和三角形看成整体全部移动到垂点上去

bonny

2. (defun c:tt (/ a b d e i p pp pt s)
   
3.         (if (and (setq e (car (entsel "\n选白线：")))
   
4.                           (setq s (ssget '((0 . "POINT"))))
   
5.                                 (setq i -1)
   
6.                         )
   
7.                 (while (setq a (ssname s (setq i (1+ i))))
   
8.                         (setq p (cdr (assoc 10 (entget a))))
   
9.                         (setq pt (vlax-curve-getClosestPointTo e p t))
   
10.                         (setq d (* 3. (distance p pt)))
    
11.                         (setq pp
    
12.                                 (list (polar p (* pi 1.25 ) d)
    
13.                                         (polar p (* pi 1.75 ) d)
    
14.                                         (polar p (* pi 0.25 ) d)
    
15.                                         (polar p (* pi 0.75 ) d)
    
16.                                         (polar p (* pi 1.25 ) d)
    
17.                                 )
    
18.                         )
    
19.                         (if (setq b (ssget "CP" pp '((0 . "LWPOLYLINE")(90 . 3)(8 . "图层3"))))
    
20.                                 (command "MOVE" b "" "non" p "non" pt)
    
21.                         )
    
22.                         (command "MOVE" a "" "non" p "non" pt)
    
23.                 )
    
24.         )
    
25. )

(defun c:tt (/ a b d e i p pp pt s)<br />         (if (and (setq e (car (entsel "\n选白线：")))<br />                           (setq s (ssget '((0 . "POINT"))))<br />                                 (setq i -1)<br />                         )<br />                 (while (setq a (ssname s (setq i (1+ i))))<br />                         (setq p (cdr (assoc 10 (entget a))))<br />                         (setq pt (vlax-curve-getClosestPointTo e p t))<br />                         (setq d (* 3. (distance p pt)))<br />                         (setq pp <br />                                 (list (polar p (* pi 1.25 ) d)<br />                                         (polar p (* pi 1.75 ) d)<br />                                         (polar p (* pi 0.25 ) d)<br />                                         (polar p (* pi 0.75 ) d)<br />                                         (polar p (* pi 1.25 ) d)<br />                                 )<br />                         )<br />                         (if (setq b (ssget "CP" pp '((0 . "LWPOLYLINE")(90 . 3)(8 . "图层3"))))<br />                                 (command "MOVE" b "" "non" p "non" pt)<br />                         )<br />                         (command "MOVE" a "" "non" p "non" pt)<br />                 )<br />         )<br /> )

lidaxiu

大概意思：按白线各自，批量法线移动

lidaxiu

lidaxiu

神速啊，大神

lidaxiu

bonny 发表于 2024-3-4 18:29

大师，还有点问题，能否帮忙看下，图形中画圈的三角形并未跟随移动，就是说有的图形未动

ssyfeng

这个应该跟ssget函数选择有关，像素会影响选择，可以试试加zoom命令缩放视口再选择

lidaxiu

(defun c:tt (/ a b d e i p pp pt s)
        (if (and (setq e (car (entsel "\n选白线：")))
                                (setq s (ssget '((0 . "POINT"))))
                                (setq i -1)
                        )
                (progn
                        (setvar "CMDECHO" 0)
                        (while (setq a (ssname s (setq i (1+ i))))
                                (setq p (cdr (assoc 10 (entget a))))
                                (setq pt (vlax-curve-getClosestPointTo e p t))
                                (setq d 0.5);距离改这个值
                                (setq pp
                                        (list (polar p (* pi 1.25 ) d)
                                                (polar p (* pi 1.75 ) d)
                                                (polar p (* pi 0.25 ) d)
                                                (polar p (* pi 0.75 ) d)
                                                (polar p (* pi 1.25 ) d)
                                        )
                                )
                                (if (setq b (ssget "CP" pp '((0 . "LWPOLYLINE")(90 . 3)(8 . "图层3"))))
                                        (command "MOVE" b "" "non" p "non" pt)
                                )
                                (command "MOVE" a "" "non" p "non" pt)
                        )
                        (setvar "CMDECHO" 1)
                )               
        )
)

lidaxiu

lidaxiu 发表于 2024-3-5 18:49
(defun c:tt (/ a b d e i p pp pt s)
        (if (and (setq e (car (entsel "\n选白线：")))
                                (setq s ( ...

把波总最终程序贴上来了