[lisp] 绘制箭头程序（直箭头，弯箭头，大弯箭头）

admin

1. (defun C:jt()
2.   (prompt "\n绘制箭头")
3.   (setvar "cmdecho" 0)
4.   (setq oldmode (getvar "osmode"))
5.   (setvar "osmode" 0)  ;关闭扑捉
6.   
7.   (initget "A B C")
8.   (setq enda (getkword "\n直箭头A/弯箭头B/大弯箭头<C> <A>")
9.         enda (if enda enda "A"))
10.         
11.    (while (setq p1 (getpoint "\n箭头的尖端位置:")
12.         p2 (getpoint p1 "\n箭头的另一端:")
13.         dd (distance p1 p2))
14.   (prompt (rtos dd 2 4))
15.   (setq w (* dd 1.2)
16.         an (angle p1 p2)
17.         p3 (polar p2 (+ an (* pi 0.5)) (/ w 2.0))
18.         p4 (polar p2 (+ an (* pi 1.5)) (/ w 2.0)))
19.   (if (= enda "A")
20.   (progn
21.   (command "solid" p1 p3 p1 p4 ""
22.            "pline" p2 "w" (* w 0.4) (* w 0.4) (polar p2 an (getdist p2)) "")
23.    )
24.    )
25.    (if (= enda "B")
26.    (command "pline" p1 "w" "0" w p2 "w" (* w 0.4) (* w 0.4) "a" pause "")
27.    )
28.    (if (= enda "C")
29.    (command "pline" p1 "w" "0" w p2 "w" (* w 0.4) (* w 1.2) "a" pause "")
30.     )
31.     (if (= p1 nil) (exit))
32.     )
33.   (setvar "osmode" oldmode)
34.   (prin1)
35. )

复制代码

admin

1. ;;;;;;;;;;;;;;;;;;;;;;;;箭头工具
2. (defun C:jt()
3.   (prompt "\n绘制箭头")
4.   (setvar "cmdecho" 0)
5.   (setq oldmode (getvar "osmode"))
6.   (setvar "osmode" 0)  ;关闭扑捉
7.   
8.   (initget "A B C")
9.   (setq enda (getkword "\n直箭头A/弯箭头B/大弯箭头<C> <A>")
10.         enda (if enda enda "A"))
11.          
12.   (while (setq p1 (getpoint "\n箭头的尖端位置:"))
13.         (setq p2 (getpoint p1 "\n箭头的另一端:")
14.               dd (distance p1 p2))
15.   (prompt (rtos dd 2 4))
16.   (setq w (* dd 1.0)
17.         an (angle p1 p2)
18.         p3 (polar p2 (+ an (* pi 0.5)) (/ w 4.0))
19.         p4 (polar p2 (+ an (* pi 1.5)) (/ w 4.0)))
20.   
21.   (if (= enda "A")
22.   (progn
23.   (command "solid" p1 p3 p1 p4 ""
24.            "pline" p2 "w" (* w 0.2) (* w 0.2) (polar p2 an (getdist p2)) "")
25.    )
26.    )
27.    (if (= enda "B")
28.    (progn
29.   (command "solid" p1 p3 p1 p4 ""
30.            "pline" p2 "w" "0" w p2 "w" (* w 0.2) (* w 0.2) "a" pause "")
31.    )
32.    )
33.    (if (= enda "C")
34.    (progn
35.   (command "solid" p1 p3 p1 p4 ""
36.            "pline" p2 "w" "0" w p2 "w" (* w 0.2) (* w 0.6) "a" pause "")
37.    )
38.    )
39.     (if (= p1 nil) (exit))
40.     )
41.   (setvar "osmode" oldmode)
42.   (prin1)
43. )

复制代码

admin

1. (defun c:tt ()
2.    (vl-load-com)
3.    (setq acad (vlax-get-acad-object))
4.    (setq acaddocument (vla-get-activedocument acad))
5.    (setq mspace (vla-get-modelspace acaddocument))
6.    (setq h (getreal "\n请输入偏移距离"))
7. (setq endata (entsel "\n请选择一条线"))
8.    (setq ename (car endata))
9.    (setq p0 (cadr endata))
10.    (setq obj (vlax-ename->vla-object ename))
11.    (setq l1 (car (vlax-safearray->list (vlax-variant-value (vla-offset obj h)))))           ;偏移曲线1
12.    (setq l2 (car (vlax-safearray->list (vlax-variant-value (vla-offset obj (* -1 h))))))    ;偏移曲线2
13.    (setq p1 (vlax-curve-getclosestpointto l1 p0 t))      ;插入点1
14.    (setq p2 (vlax-curve-getclosestpointto l2 p0 t))      ;插入点2
15.    (vla-delete l1)    ;删除曲线1
16.    (vla-delete l2)    ;删除曲线2
17.    (setq ang1 (angle p2 p1))  ;插入点1 点2角度
18.    (setq ang2 (- ang1 (/ pi 2)))  ;计算直线角度或者曲线的切线角度
19.    (setq obj (vla-insertblock mspace (vlax-3d-point p2) "11005" 1 1 1 ang2)) ;插入块名为11005的图块
20.    (setq loop t)
21.   (while loop
22.     (setq code (grread t 8))
23.     (cond
24.      ((= (car code) 5)
25.     (setq ang3 (- (angle p0 (cadr code)) ang2))     ;光标所在点与单选点的角度减去直线的或者曲线切线的角度
26.     (if (< ang3 0)
27.         (setq ang3 (+ ang3 (* 2 pi))))
28.      (cond
29.         ((and (> ang3 0 ) (< ang3  (/ pi 2)))  
30.          (vla-put-Rotation obj ang2)  
31.          (vla-put-insertionpoint obj (vlax-3d-point p1))
32.          )
33.         ((and (> ang3 (/ pi 2)) (< ang3 pi))
34.          (vla-put-Rotation obj (- ang2 pi))
35.          (vla-put-insertionpoint obj (vlax-3d-point p1))
36.          )
37.         ((and (> ang3 pi) (< ang3  (* 3 (/ pi 2))))
38.          (vla-put-Rotation obj (- ang2 pi))
39.          (vla-put-insertionpoint obj (vlax-3d-point p2))
40.          )
41.         ((and (> ang3 (* 3 (/ pi 2))) (< ang3  (* 2 pi)))
42.          (vla-put-Rotation obj ang2)
43.          (vla-put-insertionpoint obj (vlax-3d-point p2))
44.          )            
45.        )
46.     )
47.    ((= code '(25 37)) (vla-delete obj))
48.    (T (setq loop nil))
49.    )
50.    )
51.   )

复制代码

admin

1. (defun c:crtk ()
2.   (vl-load-com)
3.           (setq acad (vlax-get-acad-object))
4.           (setq acaddocument (vla-get-activedocument acad))
5.           (setq mspace (vla-get-modelspace acaddocument))
6.    (if (not (setq bl_data (vlax-ldata-get "bl_tools" "bl"))) ;读取本函数保存在图档中的数据，如果bl_data返回为空值，说明第一次运行本程序
7.     (progn
8.       ;第一次运行本程序，为确保程序正确运行，需要建立一个默认的原始数据。这个数据主要用于保存上次的设置，以便下次调用
9.       ;数据格式为一个点对表，格式为：
10.        (setq bl_data (list '(1 . 1) '(2 . 0) '(3 . "")));初始值(1.缩放系数)(2.偏移值)(3.块名)
11.        ;创建默认数据
12.       (vlax-ldata-put "bl_tools" "bl" bl_data) ;将默认数据保存到图档的字典中，以便下次调用
13.       )
14.     )
16.   (setq s (cdr (assoc 1 bl_data)) ;取出缩放系数
17.         h (cdr (assoc 2 bl_data)) ;取出偏移值
18.         enblb (cdr (assoc 3 bl_data)) ;取出块名
19.    )  ;恢复设置数据
20.   (setq gr t)
21.   
22.   (while gr ;获取用户动作，在用户点击左键后退出循环
23.   
24.    (if(/= enblb "")
25.      (progn
26.         (initget "t r")
27.         (setq endata (entsel (strcat"\n选择线[选择图块(t)][输入图块名(r)]:当前块<"(cdr (assoc 3 bl_data))">")))
28.         );progn11
29.      
30.      (progn
31.      (initget "t")
32.      (setq enbl (getstring (strcat"\n输入图块名[选择图块(t)]当前块:<"(cdr (assoc 3 bl_data))">")))
33.      (if(= enbl "t")
34.      (progn
35.      (setq enbl (entsel (strcat"\n选择块:当前块<"(cdr (assoc 3 bl_data))">")))
36.      (setq enbla (entget (car enbl)))
37.      (setq enblb (cdr (assoc 2 enbla)))
38.      (vlax-ldata-put "bl_tools" "bl" (setq bl_data (subst (cons 3 enblb) (assoc 3 bl_data) bl_data)))
39.      (setq endata (entsel (strcat"\n选择线:当前块<"(cdr (assoc 3 bl_data))">")))
40.           );progn21
41.      (progn
42.      (command "pline" '(800 0) "w" "0" "400" '(0  0) "")
43.      (command "block" enbl  '(0 0 ) (entlast) "")
44.      (setq enblb enbl)
45.      (vlax-ldata-put "bl_tools" "bl" (setq bl_data (subst (cons 3 enblb) (assoc 3 bl_data) bl_data)))
46.      (setq endata (entsel (strcat"\n选择线:当前块<"(cdr (assoc 3 bl_data))">")) ));progn22
47.     );if2
48.      );progn12
49.         );if1
50.   
51.      (if(= endata "t")
52.      (progn
53.      (setq enbl (entsel (strcat"\n选择块:当前块<"(cdr (assoc 3 bl_data))">")))
54.      (setq enbla (entget (car enbl)))
55.      (setq enblb (cdr (assoc 2 enbla)))
56.      (vlax-ldata-put "bl_tools" "bl" (setq bl_data (subst (cons 3 enblb) (assoc 3 bl_data) bl_data)))
57.      (setq endata (entsel (strcat"\n选择线:当前块<"(cdr (assoc 3 bl_data))">")))
58.           );progn31
59.     );if3
60.      (if(= endata "r")
61.      (progn
62.      (setq enbl (getstring (strcat"\n输入图块名:当前块<"(cdr (assoc 3 bl_data))">")))
63.      (setq enblb enbl)
64.      (vlax-ldata-put "bl_tools" "bl" (setq bl_data (subst (cons 3 enblb) (assoc 3 bl_data) bl_data)))
65.      (setq endata (entsel (strcat"\n选择线:当前块<"(cdr (assoc 3 bl_data))">")))
66.           );progn41
67.     );if4
68.    
69.           (if (= endata nil)
70.           (setq gr nil)
71.           (progn
72.           (setq p0 (cadr endata))
73.           (setq l1 (vlax-ename->vla-object (car endata)))
74.           (setq p1 (vlax-curve-getclosestpointto l1 p0 t))
75.           (setq ang1 (angle p1 (mapcar '+ p1 (vlax-curve-getfirstderiv l1 (vlax-curve-getparamatpoint l1 p1)))))
76.           (setq p2 (polar p1 (+ ang1 (/ pi 2)) h))
77.           (setq p3 (polar p1 (- ang1 (/ pi 2))  h))
78.           (setq obj (vla-insertblock mspace (vlax-3d-point p2) enblb s s s ang1))
79.           (setq loop t)
80.   (princ (strcat"\n指定图块位置或[偏移距离(O)<" (rtos h) ">/缩放(S)]<" (rtos s) ">"))
81.   (setq YH_mouse (grread T 5 0)) ;获取当前鼠标坐标。getpoint，grread等得到的点都是相对于用户的UCS坐标系的
82.         (while (/= (car (setq YH_mouse (grread YH_mouse 1 0))) 3) ;获取用户动作，在用户点击左键后退出循环
83.                         
84.                           (cond
85.                             ((= (car YH_mouse) 2) ;键盘输入
86.                            (setq YH_keyb (strcase (chr (cadr YH_mouse))))
87.                            (cond
88.                              ((= YH_keyb "O") ;用户键入的是O键，响应修改偏移距离
89.                              (setq h (getreal (strcat "\n输入偏移距离:当前值<" (rtos h) ">")))
90.                               (if (/= h nil)
91.                               (progn
92.                               (vlax-ldata-put "bl_tools" "bl" (setq bl_data (subst (cons 2 h) (assoc 2 bl_data) bl_data)))
93.                               (setq p2 (polar p1 (+ ang1 (/ pi 2)) h))
94.                               (setq p3 (polar p1 (- ang1 (/ pi 2)) h))
95.                                 );progn
96.                                 );if
97.                           );or21
98.                                ((= YH_keyb "S") ;用户键入的是S键，响应修改大小
99.                              (setq s (getreal (strcat "\n输入缩放系数:当前值<" (rtos s) ">")))
100.                               (if (/= s nil)
101.                               (progn
102.                         (vlax-ldata-put "bl_tools" "bl" (setq bl_data (subst (cons 1 s) (assoc 1 bl_data) bl_data)))
103.                                  (vla-delete obj)
104.                                 (setq obj (vla-insertblock mspace (vlax-3d-point p2) enblb s s s ang1))       
105.                             );progn
106.                           );if
107.                           );or22
108.                              )
109.                              );cond2
110.                              (t
111.                             (setq ang2 (- (angle p1 (cadr YH_mouse)) ang1))  
112.                             (if (< ang2 0)(setq ang2 (+ ang2 (* 2 pi))))
113.                              (cond
114.                              ((and (> ang2 0 ) (< ang2 (/ pi 2)))               
115.                               (vla-put-Rotation obj ang1)               
116.                               (vla-put-insertionpoint obj (vlax-3d-point p2))
117.                               )
118.                              ((and (> ang2 (/ pi 2) ) (< ang2 pi))               
119.                               (vla-put-Rotation obj (- ang1 pi))               
120.                               (vla-put-insertionpoint obj (vlax-3d-point p2))
121.                               )
122.                              ((and (> ang2 pi ) (< ang2  (* 3 (/ pi 2))))               
123.                               (vla-put-Rotation obj (- ang1 pi))               
124.                               (vla-put-insertionpoint obj (vlax-3d-point p3))
125.                               )
126.                              ((and (> ang2 (* 3 (/ pi 2))) (< ang2  (* pi 2)))               
127.                               (vla-put-Rotation obj ang1)               
128.                               (vla-put-insertionpoint obj (vlax-3d-point p3))
129.                               )
130.                             )
131.                                );t
132.                            );cond
133.                           
135.          
136.          ));while
138.     ));while
139. (princ "\n完成")
140.   );end

复制代码

admin

1. ;;;--------箭头线----------
2. (defun c:jt (/ olderr  txt pt pt1 pt2 pt3 i ku k1)
3.     (setq olderr  *error*
4.    *error* at_err
5.     )
6.     (setq oss (getvar "osmode"))
7.     (PROMPT"\n标注内容: 1 上;2 下")
8.     (WHILE(NOT(MEMBER(SETQ A(LAST(GRREAD)))'(49 50))))
9.     (SETQ TXT(COND((= A 49)"上")((= A 50)"下")))
10.     (setq pt0 (getpoint "\nPick point:"))
11.     (if (setq pt1 pt0)
12. (progn (setq i 0)
13.         (while (setq pt2 (getpoint pt1 "\nPick point:"))
14.      (setq ku (angle pt1 pt2))
15.      (setq k1 (+ ku pi))
16.                    (setq pt (polar pt1 k1 300))
17.      (setvar "osmode" 0)
18.                    (setVar "OrthoMode" 1)
19.                   
20.      (if (= i 0)
21.         (command "._text" "j" "mc" pt 350 0 txt)
22.                       (command "Donut" "0" "100" pt0 "" );画箭头线起点圆点   
23.      )
24.      (command "line" pt1 pt2 "")
25.      (command "")
26.      (setq pt1 pt2
27.     i   (1+ i)
28.      )
29.         )
30.         (setq pt3 (polar pt1 k1 300))
31.         (command "Pline" pt1 "W" "0" "60" pt3 "")
32.          )
33.     )
34.     (setq *error* olderr)
35.     (setvar "osmode" oss)
36.     (princ)
37. )

复制代码