动态建筑符号的【正交】程式摸索？

尘缘一生

自己写的“动态折断线”，
很遗憾，在扯动中不能使用“正交”，如何完善修改呢？

1. (defun c:ZDX(/ pt1 pt2 pt3 pt4 pt5 pt6 pt7 ang dis gr n %k i)  
   
2.   (setq pt1 (getpoint "\ngive the left point:"))
   
3.   (setq %k t) ;循环条件
   
4.   (setq i nil);初始设置）
   
5.   (while %k
   
6.     (setq gr (grread t 4 0);;取得鼠标操作及坐标
   
7.           n (car gr)       ;;鼠标操作
   
8.           pt2 (cadr gr)     ;;鼠标坐标
   
9. 
   
10.     )
    
11.     (if (= n 5) ;;没有操作
    
12.       (progn
    
13.         (if (/= i nil)
    
14.           (entdel i)
    
15.         );;如果有过度实体就删除
    
16.         (setq ang (angle pt1 pt2))
    
17.         (setq dis (distance pt1 pt2))
    
18.         (setq pt3 (polar pt1 ang (/ dis 2)))
    
19.         (setq pt4 (polar pt1 ang (- (/ dis 2) 1.3)))
    
20.         (setq pt5 (polar pt3 (+ ang (/ pi 2)) 3.5))
    
21.         (setq pt6 (polar pt3 (- ang (/ pi 2)) 3.5))
    
22.         (setq pt7 (polar pt1 ang (+ (/ dis 2) 1.3)))
    
23.         (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '
    
24.                        (90 . 5) (cons 10 pt1) (cons 10 pt4) (cons 10 pt5) (cons 10 pt6)
    
25.                        (cons 10 pt7) (cons 10 pt2)
    
26.                  )
    
27.         )
    
28.         (setq i (entlast));;得到过度实体名
    
29.       )
    
30.     )
    
31.     (if (= n 3)
    
32.       (setq %k nil)
    
33.     );;3表示左键;结束循环
    
34.     (if (or
    
35.           (= n 2)
    
36.           (= n 25)
    
37.         );;2表示空格;25表示右键;结束循环
    
38.       (progn
    
39.         (setq %k nil)
    
40.         (entdel i)
    
41.       )
    
42.     )
    
43.   )
    
44.   (print)
    
45. )
    

(defun c:ZDX(/ pt1 pt2 pt3 pt4 pt5 pt6 pt7 ang dis gr n %k i)  <br />   (setq pt1 (getpoint "\ngive the left point:"))<br />   (setq %k t) ;循环条件<br />   (setq i nil);初始设置）<br />   (while %k<br />     (setq gr (grread t 4 0);;取得鼠标操作及坐标<br />           n (car gr)       ;;鼠标操作<br />           pt2 (cadr gr)     ;;鼠标坐标<br /> <br />     )<br />     (if (= n 5) ;;没有操作<br />       (progn<br />         (if (/= i nil)<br />           (entdel i)<br />         );;如果有过度实体就删除<br />         (setq ang (angle pt1 pt2))<br />         (setq dis (distance pt1 pt2))<br />         (setq pt3 (polar pt1 ang (/ dis 2)))<br />         (setq pt4 (polar pt1 ang (- (/ dis 2) 1.3)))<br />         (setq pt5 (polar pt3 (+ ang (/ pi 2)) 3.5))<br />         (setq pt6 (polar pt3 (- ang (/ pi 2)) 3.5))<br />         (setq pt7 (polar pt1 ang (+ (/ dis 2) 1.3)))<br />         (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '<br />                        (90 . 5) (cons 10 pt1) (cons 10 pt4) (cons 10 pt5) (cons 10 pt6)<br />                        (cons 10 pt7) (cons 10 pt2)<br />                  )<br />         )<br />         (setq i (entlast));;得到过度实体名<br />       )<br />     )<br />     (if (= n 3)<br />       (setq %k nil)<br />     );;3表示左键;结束循环<br />     (if (or<br />           (= n 2)<br />           (= n 25)<br />         );;2表示空格;25表示右键;结束循环<br />       (progn<br />         (setq %k nil)<br />         (entdel i)<br />       )<br />     )<br />   ) <br />   (print)<br /> )<br />

总之：需要有正交功能的grread函数，谁有提供吗？非源码请绕行。

尘缘一生

总结本帖：
   建筑符号，已写完全，他们是：
1：折断线 ZDX
2:双折断线 ZDX1
3:箭头 JT
4：对称符号 duichen

特点：
grread方式且支持正交切换。
程序说明：
  程序内部进行了角度改写，已避免双折断线时线条交叉；
   程序适合PKPM系列，对于天正系列1:1画图来说，修改很简单，或者在实用中，把天正图纸缩小0.01倍即可
源码程序如下：

尘缘一生

终于实现了正交：程序“扑捉”部分功能暂时去掉了，经试验，不完善。

1. (defun c:ZDX-1 (/ pt1 pt2 ennext ang gr grr z)
   
2.   (setq pt1 (getpoint "\n给出起点？give the first point:"))
   
3.   (setq f8(getvar 'ORTHOMODE))
   
4.   (setvar 'cmdecho 0)
   
5.   (setq z t)
   
6.   (while z
   
7.     (setq grr (grread t ));请求输入
   
8.     (setq gr(car grr) pt2 (cadr grr))
   
9.     (cond
   
10.       ((equal grr '(2 15));F8切换正交开关
    
11.         (if (= f8 0)
    
12.           (progn(setq f8 1)(prompt "\n<正交 开>"))
    
13.           (progn(setq f8 0)(prompt "\n<正交 关>"))
    
14.         )
    
15.         (setvar 'orthomode f8)(redraw)
    
16.       )
    
17.       ((= gr 5);移动时
    
18.         (cond ((= f8 1);正交打开时
    
19.                 (setq ang (atoi (angtos (angle pt1 pt2))))
    
20.                 (if(> ang 315)(setq ang (- 360 ang)))
    
21.                 (cond ((and (< ang 45) (> ang -45))
    
22.                         (setq pt (list (car pt2) (cadr pt1)))
    
23.                       )
    
24.                   ((and (< ang 135) (> ang 45))
    
25.                     (setq pt (list (car pt1) (cadr pt2)))
    
26.                   )
    
27.                   ((and (< ang 225) (> ang 135))
    
28.                     (setq pt (list (car pt2) (cadr pt1)))
    
29.                   )
    
30.                   ((and (< ang 315) (> ang 225))
    
31.                     (setq pt (list (car pt1) (cadr pt2)))
    
32.                   )
    
33.                 )
    
34.               )   
    
35.           ((= f8 0)(setq pt pt2));正交关闭时
    
36.         )  
    
37.         (entmake-zdx);生成引线|;
    
38.       )   
    
39.       ((= gr 3);左击
    
40.         (setq z nil)
    
41.       )
    
42.       ((or(equal grr '(2 32));空格
    
43.          (equal grr '(2 13));回车
    
44.          (equal grr'(11 0));右击
    
45.        )
    
46.         (setq z nil)
    
47.       )   
    
48.     )
    
49.   )
    
50.   (redraw)
    
51.   (setvar 'cmdecho 1)
    
52.   (princ)
    
53. )
    
54. 
    
55. ;;;
    
56. (defun entmake-zdx(/ ang dis pt3 pt4 pt5 pt6 pt7);;;生成折断线
    
57.   (if ennext (entdel ennext));;删除上次画的线
    
58.   (setq ang (angle pt1 pt))
    
59.   (setq dis (distance pt1 pt))
    
60.   (setq pt3 (polar pt1 ang (/ dis 2)))
    
61.   (setq pt4 (polar pt1 ang (- (/ dis 2) 1.3)))
    
62.   (setq pt5 (polar pt3 (+ ang (/ pi 2)) 3.5))
    
63.   (setq pt6 (polar pt3 (- ang (/ pi 2)) 3.5))
    
64.   (setq pt7 (polar pt1 ang (+ (/ dis 2) 1.3)))
    
65.   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '
    
66.              (90 . 5) (cons 10 pt1) (cons 10 pt4) (cons 10 pt5) (cons 10 pt6)
    
67.              (cons 10 pt7) (cons 10 pt)
    
68.            )
    
69.   )
    
70.   (setq ennext (entlast));;提取刚划的线
    
71. )

(defun c:ZDX-1 (/ pt1 pt2 ennext ang gr grr z)<br />   (setq pt1 (getpoint "\n给出起点？give the first point:")) <br />   (setq f8(getvar 'ORTHOMODE))<br />   (setvar 'cmdecho 0)<br />   (setq z t)<br />   (while z<br />     (setq grr (grread t ));请求输入<br />     (setq gr(car grr) pt2 (cadr grr))<br />     (cond <br />       ((equal grr '(2 15));F8切换正交开关<br />         (if (= f8 0)<br />           (progn(setq f8 1)(prompt "\n<正交 开>"))<br />           (progn(setq f8 0)(prompt "\n<正交 关>"))<br />         )<br />         (setvar 'orthomode f8)(redraw)<br />       )<br />       ((= gr 5);移动时<br />         (cond ((= f8 1);正交打开时<br />                 (setq ang (atoi (angtos (angle pt1 pt2))))<br />                 (if(> ang 315)(setq ang (- 360 ang)))<br />                 (cond ((and (< ang 45) (> ang -45))<br />                         (setq pt (list (car pt2) (cadr pt1)))<br />                       )<br />                   ((and (< ang 135) (> ang 45))<br />                     (setq pt (list (car pt1) (cadr pt2)))<br />                   )<br />                   ((and (< ang 225) (> ang 135))<br />                     (setq pt (list (car pt2) (cadr pt1)))<br />                   )<br />                   ((and (< ang 315) (> ang 225))<br />                     (setq pt (list (car pt1) (cadr pt2)))<br />                   )<br />                 )<br />               )    <br />           ((= f8 0)(setq pt pt2));正交关闭时<br />         )  <br />         (entmake-zdx);生成引线|;<br />       )    <br />       ((= gr 3);左击 <br />         (setq z nil)<br />       )<br />       ((or(equal grr '(2 32));空格<br />          (equal grr '(2 13));回车<br />          (equal grr'(11 0));右击<br />        )<br />         (setq z nil)<br />       )    <br />     )<br />   )<br />   (redraw)<br />   (setvar 'cmdecho 1)<br />   (princ)<br /> )<br /> <br /> ;;;<br /> (defun entmake-zdx(/ ang dis pt3 pt4 pt5 pt6 pt7);;;生成折断线<br />   (if ennext (entdel ennext));;删除上次画的线<br />   (setq ang (angle pt1 pt))<br />   (setq dis (distance pt1 pt))<br />   (setq pt3 (polar pt1 ang (/ dis 2)))<br />   (setq pt4 (polar pt1 ang (- (/ dis 2) 1.3)))<br />   (setq pt5 (polar pt3 (+ ang (/ pi 2)) 3.5))<br />   (setq pt6 (polar pt3 (- ang (/ pi 2)) 3.5))<br />   (setq pt7 (polar pt1 ang (+ (/ dis 2) 1.3)))<br />   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '<br />              (90 . 5) (cons 10 pt1) (cons 10 pt4) (cons 10 pt5) (cons 10 pt6)<br />              (cons 10 pt7) (cons 10 pt)<br />            )<br />   )<br />   (setq ennext (entlast));;提取刚划的线 <br /> )

尘缘一生

应用实例：
两个命令：折断线；箭头

发过来，立春了，给论坛拜年，更有两点期望：
1：线性建筑符号，还有：对称符号；双折断线等，希望谁能编出来下，按这种办法编写，基本就是高仿PKPM的，很实用。
2：下面这个应用实例，整合的自以为很不好，不知道谁能改写，整合好一些呢？

1. (defun C:JT-2();;;画箭头符号，支持正交
   
2.   (jzfh 2)
   
3. )
   
4. (defun C:ZDX-2();;;;画折断线符号，支持正交
   
5.   (jzfh 1)
   
6. )
   
7. (defun jzfh (k / ennext pt1 pt2 ang gr grr z)
   
8.   (setq pt1 (getpoint "\n给出起点？give the first point:"))
   
9.   (setq f8(getvar 'ORTHOMODE))
   
10.   (setvar 'cmdecho 0)
    
11.   (setq z t)
    
12.   (while z
    
13.     (setq grr (grread t ));请求输入
    
14.     (setq gr(car grr) pt2 (cadr grr))
    
15.     (cond
    
16.       ((equal grr '(2 15));F8切换正交开关
    
17.         (if (= f8 0)
    
18.           (progn(setq f8 1)(prompt "\n<正交 开>"))
    
19.           (progn(setq f8 0)(prompt "\n<正交 关>"))
    
20.         )
    
21.         (setvar 'orthomode f8)(redraw)
    
22.       )
    
23.       ((= gr 5);移动时
    
24.         (cond ((= f8 1);正交打开时
    
25.                 (setq ang (atoi (angtos (angle pt1 pt2))))
    
26.                 (if(> ang 315)(setq ang (- 360 ang)))
    
27.                 (cond ((and (< ang 45) (> ang -45))
    
28.                         (setq pt (list (car pt2) (cadr pt1)))
    
29.                       )
    
30.                   ((and (< ang 135) (> ang 45))
    
31.                     (setq pt (list (car pt1) (cadr pt2)))
    
32.                   )
    
33.                   ((and (< ang 225) (> ang 135))
    
34.                     (setq pt (list (car pt2) (cadr pt1)))
    
35.                   )
    
36.                   ((and (< ang 315) (> ang 225))
    
37.                     (setq pt (list (car pt1) (cadr pt2)))
    
38.                   )
    
39.                 )
    
40.               )   
    
41.           ((= f8 0)(setq pt pt2));正交关闭时
    
42.         )  
    
43.         (if (= k 1)
    
44.           (progn
    
45.             ;;;(command "LAYER" "S" "MM" "")
    
46.             (if ennext (entdel ennext));;删除上次画的实体
    
47.             (entmake-zdx);生成折断线|;
    
48.             (setq ennext (entlast));;提取刚画的实体
    
49.             ;;;(command "LAYER" "S" "0SX" "")
    
50.           )
    
51.       )
    
52.       (if (= k 2)
    
53.         (progn
    
54.         ;;;  (command "LAYER" "S" "MM" "")
    
55.           (entmake-jt);生成箭头|;
    
56.         ;;;  (command "LAYER" "S" "0SX" "")
    
57.         )
    
58.       )
    
59.     )   
    
60.     ((= gr 3);左击
    
61.       (setq z nil)
    
62.     )
    
63.     ((or(equal grr '(2 32));空格
    
64.        (equal grr '(2 13));回车
    
65.        (equal grr'(11 0));右击
    
66.      )
    
67.       (setq z nil)
    
68.     )   
    
69.   )
    
70. )
    
71. (redraw)
    
72. (setvar 'cmdecho 1)
    
73. (princ)
    
74. )
    
75. 
    
76. ;;;
    
77. (defun entmake-zdx(/ ang dis pt3 pt4 pt5 pt6 pt7);;;生成折断线  
    
78.   (setq ang (angle pt1 pt))
    
79.   (setq dis (distance pt1 pt))
    
80.   (setq pt3 (polar pt1 ang (/ dis 2)))
    
81.   (setq pt4 (polar pt1 ang (- (/ dis 2) 1.3)))
    
82.   (setq pt5 (polar pt3 (+ ang (/ pi 2)) 3.5))
    
83.   (setq pt6 (polar pt3 (- ang (/ pi 2)) 3.5))
    
84.   (setq pt7 (polar pt1 ang (+ (/ dis 2) 1.3)))
    
85.   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '
    
86.              (90 . 5) (cons 10 pt1) (cons 10 pt4) (cons 10 pt5) (cons 10 pt6)
    
87.              (cons 10 pt7) (cons 10 pt)
    
88.            )
    
89.   )
    
90. )
    
91. ;;;;;
    
92. (defun entmake-jt(/ ang dis pt3 pt4);;;生成箭头
    
93.   (if ennext (progn
    
94.                (entdel(ssname  ennext  0))
    
95.                (entdel(ssname  ennext  1))
    
96.              )
    
97.   );;删除上次画的实体
    
98.   (setq ang (angle pt1 pt))
    
99.   (setq dis (distance pt1 pt))
    
100.   (setq pt3 (polar pt (- (+ pi ang) 0.25) 5))
     
101.   (setq pt4 (polar pt (- 0.0 (- (- pi ang) 0.25)) 5))
     
102.   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '
     
103.              (90 . 5) (cons 10 pt1) (cons 10 pt) (cons 10 pt3)
     
104.            )
     
105.   )
     
106.   (setq ennext(ssadd))
     
107.   (ssadd (entlast) ennext)
     
108.   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '
     
109.              (90 . 5) (cons 10 pt) (cons 10 pt4)
     
110.            )
     
111.   )
     
112.   (ssadd (entlast) ennext)
     
113. )

(defun C:JT-2();;;画箭头符号，支持正交<br />   (jzfh 2)<br /> )<br /> (defun C:ZDX-2();;;;画折断线符号，支持正交<br />   (jzfh 1)<br /> )<br /> (defun jzfh (k / ennext pt1 pt2 ang gr grr z)<br />   (setq pt1 (getpoint "\n给出起点？give the first point:")) <br />   (setq f8(getvar 'ORTHOMODE))<br />   (setvar 'cmdecho 0)<br />   (setq z t)<br />   (while z<br />     (setq grr (grread t ));请求输入<br />     (setq gr(car grr) pt2 (cadr grr))<br />     (cond <br />       ((equal grr '(2 15));F8切换正交开关<br />         (if (= f8 0)<br />           (progn(setq f8 1)(prompt "\n<正交 开>"))<br />           (progn(setq f8 0)(prompt "\n<正交 关>"))<br />         )<br />         (setvar 'orthomode f8)(redraw)<br />       )<br />       ((= gr 5);移动时<br />         (cond ((= f8 1);正交打开时<br />                 (setq ang (atoi (angtos (angle pt1 pt2))))<br />                 (if(> ang 315)(setq ang (- 360 ang)))<br />                 (cond ((and (< ang 45) (> ang -45))<br />                         (setq pt (list (car pt2) (cadr pt1)))<br />                       )<br />                   ((and (< ang 135) (> ang 45))<br />                     (setq pt (list (car pt1) (cadr pt2)))<br />                   )<br />                   ((and (< ang 225) (> ang 135))<br />                     (setq pt (list (car pt2) (cadr pt1)))<br />                   )<br />                   ((and (< ang 315) (> ang 225))<br />                     (setq pt (list (car pt1) (cadr pt2)))<br />                   )<br />                 )<br />               )    <br />           ((= f8 0)(setq pt pt2));正交关闭时<br />         )  <br />         (if (= k 1) <br />           (progn<br />             ;;;(command "LAYER" "S" "MM" "")<br />             (if ennext (entdel ennext));;删除上次画的实体<br />             (entmake-zdx);生成折断线|;<br />             (setq ennext (entlast));;提取刚画的实体 <br />             ;;;(command "LAYER" "S" "0SX" "")<br />           )<br />       )<br />       (if (= k 2) <br />         (progn<br />         ;;;  (command "LAYER" "S" "MM" "")<br />           (entmake-jt);生成箭头|;<br />         ;;;  (command "LAYER" "S" "0SX" "")<br />         )<br />       )<br />     )    <br />     ((= gr 3);左击 <br />       (setq z nil)<br />     )<br />     ((or(equal grr '(2 32));空格<br />        (equal grr '(2 13));回车<br />        (equal grr'(11 0));右击<br />      )<br />       (setq z nil)<br />     )    <br />   )<br /> )<br /> (redraw)<br /> (setvar 'cmdecho 1)<br /> (princ)<br /> )<br /> <br /> ;;;<br /> (defun entmake-zdx(/ ang dis pt3 pt4 pt5 pt6 pt7);;;生成折断线  <br />   (setq ang (angle pt1 pt))<br />   (setq dis (distance pt1 pt))<br />   (setq pt3 (polar pt1 ang (/ dis 2)))<br />   (setq pt4 (polar pt1 ang (- (/ dis 2) 1.3)))<br />   (setq pt5 (polar pt3 (+ ang (/ pi 2)) 3.5))<br />   (setq pt6 (polar pt3 (- ang (/ pi 2)) 3.5))<br />   (setq pt7 (polar pt1 ang (+ (/ dis 2) 1.3)))<br />   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '<br />              (90 . 5) (cons 10 pt1) (cons 10 pt4) (cons 10 pt5) (cons 10 pt6)<br />              (cons 10 pt7) (cons 10 pt)<br />            )<br />   )<br /> )<br /> ;;;;;<br /> (defun entmake-jt(/ ang dis pt3 pt4);;;生成箭头<br />   (if ennext (progn <br />                (entdel(ssname  ennext  0))<br />                (entdel(ssname  ennext  1))<br />              )<br />   );;删除上次画的实体<br />   (setq ang (angle pt1 pt))<br />   (setq dis (distance pt1 pt))<br />   (setq pt3 (polar pt (- (+ pi ang) 0.25) 5))<br />   (setq pt4 (polar pt (- 0.0 (- (- pi ang) 0.25)) 5))<br />   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '<br />              (90 . 5) (cons 10 pt1) (cons 10 pt) (cons 10 pt3)<br />            )<br />   )<br />   (setq ennext(ssadd))<br />   (ssadd (entlast) ennext)<br />   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '<br />              (90 . 5) (cons 10 pt) (cons 10 pt4) <br />            )<br />   )<br />   (ssadd (entlast) ennext)<br /> )

fl202

谢谢楼主分享。程序中的折线对我来说比较小，我给改大了。另外又加了一条折线。
下载链接见：
演示动画见：

qyming

一？？？？？

蓝盾设计

学习，学习！研究一下！

yoyoho

下载学习,感谢分享!!!!!!