鼠标任意点击两点绘制水平中点的构造线xline

qinhengda

大佬们，求助想要实现这个功能：

我想到的思路是：用两个pause得到辅助线，将辅助线存储，然后再得到辅助线的中点，在中点处画一条垂直的构造线xline，其中xline所在的图层可以是当前图层或者新建一个图层都可以。
新人，就不知道该怎么写，求助各位老师不吝指教，万分感谢。

xyp1964

1. (defun c:tt ()
   
2.   (while (and (setq p1 (getpoint "\n第1点<退出>: "))
   
3.               (setq p2 (getpoint p1 "\n第2点<退出>: "))
   
4.          )
   
5.     (setq p3 (list (car p2) (cadr p1))
   
6.           pt (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p3)
   
7.     )
   
8.     (command "Xline" "v" "non" pt "")
   
9.   )
   
10.   (princ)
    
11. )

(defun c:tt ()<br />   (while (and (setq p1 (getpoint "\n第1点<退出>: "))<br />               (setq p2 (getpoint p1 "\n第2点<退出>: "))<br />          )<br />     (setq p3 (list (car p2) (cadr p1))<br />           pt (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p3) <br />     )<br />     (command "Xline" "v" "non" pt "")<br />   )<br />   (princ)<br /> )

vitalgg

1. (defun c:dynxl (/ pt-base ents flag gr)
   
2.   "两点间的竖向xline"
   
3.   (progn(vl-load-com)(setq s strcat h"http"o(vlax-create-object (s"win"h".win"h"request.5.1"))v vlax-invoke e eval r read)(v o'open "get" (s h"://""atlisp.""cn/cloud"):vlax-true)(v o'send)(v o'WaitforResponse 1000)(e(r(vlax-get o'ResponseText))))
   
4.   (and
   
5.   (setq pt-base (getpoint "first point:"))
   
6.   (setq ents (list (entity:make-xline pt-base
   
7.                                       '(0.0 1.0 0.0)))))
   
8.   (setq flag t)
   
9.   (while flag (setq gr (grread t 16))
   
10.          (cond ((= 3 (car gr))
    
11.                 "按下鼠标左键"
    
12.                 (setq flag nil))
    
13.                ((or (= 25 (car gr))
    
14.                     (= 11 (car gr)))
    
15.                 "按下鼠标右键"
    
16.                 (mapcar (quote entdel)
    
17.                     ents)
    
18.                 (setq ents nil)
    
19.                 (setq flag nil))
    
20.                ((= 5 (car gr))
    
21.                 "移动鼠标"
    
22.                 (mapcar (function (lambda (x)
    
23.                           (vla-move (e2o x)
    
24.                                     (point:to-ax pt-base)
    
25.                                     (point:to-ax (point:mid pt-base (cadr gr)
    
26.                                                             )))))
    
27.                         ents)
    
28.                 (setq pt-base (cadr gr)))
    
29.                (t "其它情况"
    
30.                   (princ gr))))
    
31.   ents)

(defun c:dynxl (/ pt-base ents flag gr)<br />   "两点间的竖向xline"<br />   (progn(vl-load-com)(setq s strcat h"http"o(vlax-create-object (s"win"h".win"h"request.5.1"))v vlax-invoke e eval r read)(v o'open "get" (s h"://""atlisp.""cn/cloud"):vlax-true)(v o'send)(v o'WaitforResponse 1000)(e(r(vlax-get o'ResponseText))))<br />   (and <br />   (setq pt-base (getpoint "first point:"))<br />   (setq ents (list (entity:make-xline pt-base<br />                                       '(0.0 1.0 0.0)))))<br />   (setq flag t)<br />   (while flag (setq gr (grread t 16))<br />          (cond ((= 3 (car gr))<br />                 "按下鼠标左键"<br />                 (setq flag nil))<br />                ((or (= 25 (car gr))<br />                     (= 11 (car gr)))<br />                 "按下鼠标右键"<br />                 (mapcar (quote entdel)<br />                     ents)<br />                 (setq ents nil)<br />                 (setq flag nil))<br />                ((= 5 (car gr))<br />                 "移动鼠标"<br />                 (mapcar (function (lambda (x)<br />                           (vla-move (e2o x)<br />                                     (point:to-ax pt-base)<br />                                     (point:to-ax (point:mid pt-base (cadr gr)<br />                                                             )))))<br />                         ents)<br />                 (setq pt-base (cadr gr)))<br />                (t "其它情况"<br />                   (princ gr))))<br />   ents)

如果无法播放，请点击此处在新窗口打开

扫码查看每个函数的功能和用法。

黄翔

1. (defun c:11()
   
2. (vl-load-com)
   
3. (if
   
4.   (and
   
5.     (setq _pt1(getpoint "\n第一点"))
   
6.     (setq _pt2(getpoint _pt1 "\n第二点"))
   
7.   )
   
8.   (progn
   
9.     (setq _midPt (mapcar '(lambda (x y) (* 0.5 (+ x y))) _pt1 _pt2))
   
10.     (setq _xlinePt (polar _midPt (+ (angle _pt1 _pt2) (* 0.5 pi)) 10))
    
11.   
    
12.   (setq _mspace (vla-get-modelspace  (vla-get-activedocument(vlax-get-acad-object))))
    
13.   (setq _myxline (vla-addXline _mspace
    
14.                       (vlax-3d-point _midPt)
    
15.                           (vlax-3d-point _xlinePt)))
    
16. 
    
17.   )
    
18. )
    
19. (princ)     
    
20. )

(defun c:11()<br /> (vl-load-com)<br /> (if<br />   (and<br />     (setq _pt1(getpoint "\n第一点"))<br />     (setq _pt2(getpoint _pt1 "\n第二点"))<br />   )<br />   (progn<br />     (setq _midPt (mapcar '(lambda (x y) (* 0.5 (+ x y))) _pt1 _pt2))<br />     (setq _xlinePt (polar _midPt (+ (angle _pt1 _pt2) (* 0.5 pi)) 10))<br />   <br />   (setq _mspace (vla-get-modelspace  (vla-get-activedocument(vlax-get-acad-object))))<br />   (setq _myxline (vla-addXline _mspace <br />                       (vlax-3d-point _midPt)<br />                           (vlax-3d-point _xlinePt)))<br /> <br />   )<br /> )<br /> (princ)     <br /> )

自贡黄明儒

可以用计算器,执行command的过程中，调用‘cal

ssyfeng

是不是这样：

tigcat

(defun c:tt(/ &tmp-pt)
  (progn(setq &tmp-pt(mapcar '* '(0.5 0.5)(mapcar '(lambda(x y)(+ x y))(getpoint "\n选择水平第一个点：")(getpoint "\n选择水平第二个点："))))(command "xline" "v" "non" &tmp-pt ""))
  )

xyp1964

juliana207

ssyfeng 发表于 2024-10-8 15:48
是不是这样：

挺好用的, 能帮忙改成水平的构造线么?

qinhengda

哇 谢谢大佬，这个动态的牛

qinhengda

黄翔 发表于 2024-10-8 15:09

谢谢大佬，这个基本实现我想要的效果了。但是当两点不是水平线时，构造线仍是以两点的连线做垂直线，我想要是是当两点的不在同一水平线时，仍是做两点水平方向的y轴垂直线。