[LISP程序]：一个制图中件号标注的程序，转为化工设备类制图而作.

正航

;;一个标注件号的程序，可以选择不同标注方式，自动区分标注方向，自动累加序号。请使用前加载DOSLIB6,当然纯为了输入界面漂亮点，可以不用(需要修改原代码) 。
;;本人原创。

2. 
   
3. (defun c:BJH (/ dcl_id p1 p2 p3 p4 d e1 txt no osm tc zi nt nox no)
   
4.   (setq tc (getvar "clayer"))
   
5.   (setq zi (getvar "textstyle"))
   
6.   (setq osm (getvar "osmode"))
   
7.   (setvar "orthomode" 0)
   
8.   (setvar "CMDECHO" 0)
   
9.   (setvar "regenmode" 0)
   
10.   (princ "\n            =======  件号标注程序  =======      ")
    
11.   (princ
    
12.     "\n   当您输入件号A时,将进行向上重叠标注;当您输入件号B时,进行水平连续标注，X退出。"
    
13.   )
    
14.   (setq d "TK")
    
15.   (setq e1 1)
    
16.   (setvar "osmode" 0)
    
17.   (while d
    
18.     (setq no (dos_getstring "件号标注" "请输入件号：" (itoa e1)))
    
19.     (if        (= no nil)
    
20.       (setq d nil)
    
21.       (progn
    
22.         (setq nt no)
    
23.         (if (or (= no "X") (= no "x"))
    
24.           ;;退出循环
    
25.           (setq d nil)
    
26.           (progn
    
27.             (if        (= no "")
    
28.               (setq no (itoa e1))
    
29.               ;;预赋值
    
30.             )
    
31.             (if        (or (= no "a") (= no "A"))
    
32.               (zcadjh2)
    
33.               ;;直
    
34.             )
    
35.             (if        (or (= no "b") (= no "B"))
    
36.               (zcadjh3)
    
37.             )
    
38.             (if        (and (/= nt "a") (/= nt "b") (/= nt "A") (/= nt "B"))
    
39.               (progn
    
40.                 (setq nox (atoi no))
    
41.                 (if (= nox 0)
    
42.                   (progn
    
43.                     (alert
    
44.                       "\n  对不起,您输入了非法的件号!程序将中止执行.\n\n           请核对后重新开始."
    
45.                     )
    
46.                     (setq d nil)
    
47.                   )
    
48.                 )
    
49.                 (if (/= nox 0)
    
50.                   (zcadjh1)
    
51.                 )
    
52.               )
    
53.             )
    
54.           )
    
55.         )
    
56.       )
    
57.     )
    
58.   )
    
59.   (setvar "osmode" osm)
    
60.   (setvar "clayer" tc)
    
61.   (setvar "textstyle" zi)
    
62.   (princ)
    
63. )
    
64. 
    
65. (defun zcadjh1 ()
    
66.   ;;普通形式
    
67.   (setq p1 (getpoint "\n目标件位置:"))
    
68.   (if (= p1 nil)
    
69.     (setq d nil)
    
70.   )
    
71.   (if (/= p1 nil)
    
72.     (progn
    
73.       (setq p2 (getpoint p1 "\n标号位置:"))
    
74.       (if (>= (car p2) (car p1))
    
75.         (setq p3 (list (+ (car p2) 12) (cadr p2)))
    
76.       )
    
77.       (if (< (car p2) (car p1))
    
78.         (setq p3 (list (- (car p2) 12) (cadr p2)))
    
79.       )
    
80.       (setq p4 (list (/ (+ (car p3) (car p2)) 2) (+ (cadr p3) 1)))
    
81.       (command ".LAYER" "S" "14" (terpri))
    
82.       (setq txt no)
    
83.       (COMMAND ".TEXT" "_c" P4 "0" txt)
    
84.       (command ".pline" p2 p3 "")
    
85.       (command ".undo" "be")
    
86.       (command ".pline"        p1 "H" "0.1" ""        "A" "r"        "0.081"        "A" "359.999" "" "L" "H"
    
87.                "0" "0" p2 "")
    
88.       (command ".undo" "e")
    
89.       (setq txt (itoa nox))
    
90.       (setq e1 nox)
    
91.       (setq nox (+ nox 1))
    
92.       (setq e1 (+ 1 e1))
    
93.     )
    
94.   )
    
95. )
    
96. 
    
97. (defun zcadjh2 () ;垂直标
    
98.   (command ".layer" "s" "14" "")
    
99.   (if (>= (car p1) (car p2))
    
100.     (zcadjh21)
     
101.     (zcadjh22)
     
102.   )
     
103. )
     
104. 
     
105. (defun zcadjh21        ()
     
106.   (setq pg p2)
     
107.   (setq p2 (list (car p2) (+ (cadr p2) 8)))
     
108.   (setq p3 (list (car p3) (+ (cadr p3) 8)))
     
109.   (setq p4 (list (/ (+ (car p2) (car p3)) 2) (+ (cadr p3) 1.5)))
     
110.   (setq txt (rtos e1))
     
111.   (command ".text" "_C" p4 "0" txt)
     
112.   (command ".pline" pg p2 p3 "")
     
113.   (setq txt (itoa nox))
     
114.   (setq e1 nox)
     
115.   (setq nox (+ nox 1))
     
116.   (setq e1 (+ 1 e1))
     
117.   (setq no (itoa nox))
     
118. )
     
119. 
     
120. (defun zcadjh22        ()
     
121.   (command ".undo" "2")
     
122.   (command ".layer" "s" "14" "")
     
123.   (setq pg p2)
     
124.   (setq p2 (list (car p2) (- (cadr p2) 8)))
     
125.   (setq p3 (list (car p3) (- (cadr p3) 8)))
     
126.   (setq p4 (list (/ (+ (car p2) (car p3)) 2) (+ (cadr p3) 1.5)))
     
127.   (setq        k1 (list (/ (+ (car p1) (car pg)) 2)
     
128.                  (/ (+ (cadr p1) (cadr pg)) 2)
     
129.            )
     
130.   )
     
131.   (setq txt (rtos e1))
     
132.   (command ".text" "_C" p4 "0" txt)
     
133.   (command ".pline" pg p2 p3 "")
     
134.   (setq txt (itoa nox))
     
135.   (setq e1 nox)
     
136.   (setq nox (+ nox 1))
     
137.   (setq e1 (+ 1 e1))
     
138.   (setq no (itoa nox))
     
139.   (command ".undo" "be")
     
140.   (command ".pline" p1 "H" "0.1" "" "A"        "r" "0.081" "A"        "359.999" "" "L" "H" "0"
     
141.            "0" p2 "")
     
142.   (command ".undo" "e")
     
143. )
     
144. 
     
145. 
     
146. (defun zcadjh3 () ;水平标
     
147.   (command ".layer" "s" "02" "")
     
148.   (if (>= (car p2) (car p1))
     
149.     (zcadjh31)
     
150.     (zcadjh32)
     
151.   )
     
152.   (setq txt (itoa nox))
     
153.   (setq e1 nox)
     
154.   (command ".layer" "s" "14" "")
     
155.   (command ".text" "_C" p4 "0" txt)
     
156.   (command ".pline" pg pk p2 p3 "")
     
157.   (setq nox (+ nox 1))
     
158.   (setq no (itoa nox))
     
159.   (setq e1 (+ 1 e1))
     
160. )
     
161. 
     
162. (defun zcadjh31        ()
     
163.   (setq pg p3)
     
164.   (setq pk (list (+ (car p3) 2) (- (cadr p3) 2)))
     
165.   (setq p2 (list (+ (car p2) 16) (cadr p2)))
     
166.   (setq p3 (list (+ (car p2) 12) (cadr p2)))
     
167.   (setq p4 (list (/ (+ (car p2) (car p3)) 2) (+ (cadr p3) 1.5)))
     
168. )
     
169. 
     
170. (defun zcadjh32        ()
     
171.   (setq pg p3)
     
172.   (setq pk (list (- (car p3) 2) (- (cadr p3) 2)))
     
173.   (setq p2 (list (- (car p3) 4) (cadr p2)))
     
174.   (setq p3 (list (- (car p2) 12) (cadr p2)))
     
175.   (setq p4 (list (/ (+ (car p2) (car p3)) 2) (+ (cadr p3) 1.5)))
     
176. )
     
177. 
     

<br /> (defun c:BJH (/ dcl_id p1 p2 p3 p4 d e1 txt no osm tc zi nt nox no)<br />   (setq tc (getvar "clayer"))<br />   (setq zi (getvar "textstyle"))<br />   (setq osm (getvar "osmode"))<br />   (setvar "orthomode" 0)<br />   (setvar "CMDECHO" 0)<br />   (setvar "regenmode" 0)<br />   (princ "\n            =======  件号标注程序  =======      ")<br />   (princ<br />     "\n   当您输入件号A时,将进行向上重叠标注;当您输入件号B时,进行水平连续标注，X退出。"<br />   )<br />   (setq d "TK")<br />   (setq e1 1)<br />   (setvar "osmode" 0)<br />   (while d<br />     (setq no (dos_getstring "件号标注" "请输入件号：" (itoa e1)))<br />     (if        (= no nil)<br />       (setq d nil)<br />       (progn<br />         (setq nt no)<br />         (if (or (= no "X") (= no "x"))<br />           ;;退出循环<br />           (setq d nil)<br />           (progn<br />             (if        (= no "")<br />               (setq no (itoa e1))<br />               ;;预赋值<br />             )<br />             (if        (or (= no "a") (= no "A"))<br />               (zcadjh2)<br />               ;;直<br />             )<br />             (if        (or (= no "b") (= no "B"))<br />               (zcadjh3)<br />             )<br />             (if        (and (/= nt "a") (/= nt "b") (/= nt "A") (/= nt "B"))<br />               (progn<br />                 (setq nox (atoi no))<br />                 (if (= nox 0)<br />                   (progn<br />                     (alert<br />                       "\n  对不起,您输入了非法的件号!程序将中止执行.\n\n           请核对后重新开始."<br />                     )<br />                     (setq d nil)<br />                   )<br />                 )<br />                 (if (/= nox 0)<br />                   (zcadjh1)<br />                 )<br />               )<br />             )<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (setvar "osmode" osm)<br />   (setvar "clayer" tc)<br />   (setvar "textstyle" zi)<br />   (princ)<br /> )<br /> <br /> (defun zcadjh1 ()<br />   ;;普通形式<br />   (setq p1 (getpoint "\n目标件位置:"))<br />   (if (= p1 nil)<br />     (setq d nil)<br />   )<br />   (if (/= p1 nil)<br />     (progn<br />       (setq p2 (getpoint p1 "\n标号位置:"))<br />       (if (>= (car p2) (car p1))<br />         (setq p3 (list (+ (car p2) 12) (cadr p2)))<br />       )<br />       (if (< (car p2) (car p1))<br />         (setq p3 (list (- (car p2) 12) (cadr p2)))<br />       )<br />       (setq p4 (list (/ (+ (car p3) (car p2)) 2) (+ (cadr p3) 1)))<br />       (command ".LAYER" "S" "14" (terpri))<br />       (setq txt no)<br />       (COMMAND ".TEXT" "_c" P4 "0" txt)<br />       (command ".pline" p2 p3 "")<br />       (command ".undo" "be")<br />       (command ".pline"        p1 "H" "0.1" ""        "A" "r"        "0.081"        "A" "359.999" "" "L" "H"<br />                "0" "0" p2 "")<br />       (command ".undo" "e")<br />       (setq txt (itoa nox))<br />       (setq e1 nox)<br />       (setq nox (+ nox 1))<br />       (setq e1 (+ 1 e1))<br />     )<br />   )<br /> )<br /> <br /> (defun zcadjh2 () ;垂直标<br />   (command ".layer" "s" "14" "")<br />   (if (>= (car p1) (car p2))<br />     (zcadjh21)<br />     (zcadjh22)<br />   )<br /> )<br /> <br /> (defun zcadjh21        ()<br />   (setq pg p2)<br />   (setq p2 (list (car p2) (+ (cadr p2) 8)))<br />   (setq p3 (list (car p3) (+ (cadr p3) 8)))<br />   (setq p4 (list (/ (+ (car p2) (car p3)) 2) (+ (cadr p3) 1.5)))<br />   (setq txt (rtos e1))<br />   (command ".text" "_C" p4 "0" txt)<br />   (command ".pline" pg p2 p3 "")<br />   (setq txt (itoa nox))<br />   (setq e1 nox)<br />   (setq nox (+ nox 1))<br />   (setq e1 (+ 1 e1))<br />   (setq no (itoa nox))<br /> )<br /> <br /> (defun zcadjh22        ()<br />   (command ".undo" "2")<br />   (command ".layer" "s" "14" "")<br />   (setq pg p2)<br />   (setq p2 (list (car p2) (- (cadr p2) 8)))<br />   (setq p3 (list (car p3) (- (cadr p3) 8)))<br />   (setq p4 (list (/ (+ (car p2) (car p3)) 2) (+ (cadr p3) 1.5)))<br />   (setq        k1 (list (/ (+ (car p1) (car pg)) 2)<br />                  (/ (+ (cadr p1) (cadr pg)) 2)<br />            )<br />   )<br />   (setq txt (rtos e1))<br />   (command ".text" "_C" p4 "0" txt)<br />   (command ".pline" pg p2 p3 "")<br />   (setq txt (itoa nox))<br />   (setq e1 nox)<br />   (setq nox (+ nox 1))<br />   (setq e1 (+ 1 e1))<br />   (setq no (itoa nox))<br />   (command ".undo" "be")<br />   (command ".pline" p1 "H" "0.1" "" "A"        "r" "0.081" "A"        "359.999" "" "L" "H" "0"<br />            "0" p2 "")<br />   (command ".undo" "e")<br /> )<br /> <br /> <br /> (defun zcadjh3 () ;水平标<br />   (command ".layer" "s" "02" "")<br />   (if (>= (car p2) (car p1))<br />     (zcadjh31)<br />     (zcadjh32)<br />   )<br />   (setq txt (itoa nox))<br />   (setq e1 nox)<br />   (command ".layer" "s" "14" "")<br />   (command ".text" "_C" p4 "0" txt)<br />   (command ".pline" pg pk p2 p3 "")<br />   (setq nox (+ nox 1))<br />   (setq no (itoa nox))<br />   (setq e1 (+ 1 e1))<br /> )<br /> <br /> (defun zcadjh31        ()<br />   (setq pg p3)<br />   (setq pk (list (+ (car p3) 2) (- (cadr p3) 2)))<br />   (setq p2 (list (+ (car p2) 16) (cadr p2)))<br />   (setq p3 (list (+ (car p2) 12) (cadr p2)))<br />   (setq p4 (list (/ (+ (car p2) (car p3)) 2) (+ (cadr p3) 1.5)))<br /> )<br /> <br /> (defun zcadjh32        ()<br />   (setq pg p3)<br />   (setq pk (list (- (car p3) 2) (- (cadr p3) 2)))<br />   (setq p2 (list (- (car p3) 4) (cadr p2)))<br />   (setq p3 (list (- (car p2) 12) (cadr p2)))<br />   (setq p4 (list (/ (+ (car p2) (car p3)) 2) (+ (cadr p3) 1.5)))<br /> )<br /> <br />

whbandgp

不懂

Michael_66

谢谢！能遇到搞化工设备的朋友。

xjxing

我将原码复制后保存为doslib6.lsp文件在2004中加载，但不知输入什么命令，请1楼详细说明使用方法。

anewfish

加载后，直接输入bjh即可。

2443725

好象不行啊

命令: _appload 已成功加载 bjh.lsp。


命令:
命令:
命令: bjh

            =======  件号标注程序  =======
   
当您输入件号A时,将进行向上重叠标注;当您输入件号B时,进行水平连续标注，X退出。;
错误: no function definition: DOS_GETSTRING

命令:
命令: bjh

            =======  件号标注程序  =======
   
当您输入件号A时,将进行向上重叠标注;当您输入件号B时,进行水平连续标注，X退出。;
错误: no function definition: DOS_GETSTRING

htm

我在r14上加载后运行错误。

2443725

楼主还没修改啊？
大家可以去化工设备技术论坛看看
http://hgbbs.hxlt.com/
那里也不错！！