[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.     )
    
15. 
    
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.                           
     
134. 
     
135.          
     
136.          ));while
     
137. 
     
138.     ));while
     
139. (princ "\n完成")
     
140.   );end
     
141. 
     
142. 
     
143. 
     

复制代码

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. )

复制代码