[源码]动态粗糙度

cabinsummer

只贴出源码，原理详见我以前的帖子http://bbs.mjtd.com/thread-90666-1-1.html

1. roughness:dialog
   
2. {
   
3.   label="粗糙度";
   
4.   spacer;
   
5.   :row
   
6.   {
   
7.     :column
   
8.     {
   
9.       :image_button
   
10.       {
    
11.         key = "RM";
    
12.         aspect_ratio = 1;
    
13.         width        = 8;
    
14.         fixed_width  = true;
    
15.         color        = graphics_background;
    
16.         allow_accept = true;
    
17.       }
    
18.       :image_button
    
19.       {
    
20.         key = "UN";
    
21.         aspect_ratio = 1;
    
22.         width        = 8;
    
23.         fixed_width  = true;
    
24.         color        = graphics_background;
    
25.         allow_accept = true;
    
26.       }
    
27.       :image_button
    
28.       {
    
29.         key = "BS";
    
30.         aspect_ratio = 1;
    
31.         width        = 8;
    
32.         fixed_width  = true;
    
33.         color        = graphics_background;
    
34.         allow_accept = true;
    
35.       }
    
36.     }
    
37.     :list_box
    
38.     {
    
39.       key="RV";
    
40.       value=8;
    
41.       width=16;
    
42.       height=14;
    
43.       allow_accept=true;
    
44.     }
    
45.   }
    
46.   :errtile
    
47.   {
    
48.     width=18;
    
49.   }
    
50.   ok_cancel;
    
51. }

roughness:dialog<br /> {<br />   label="粗糙度";<br />   spacer;<br />   :row<br />   {<br />     :column<br />     {<br />       :image_button<br />       {<br />         key = "RM";<br />         aspect_ratio = 1;<br />         width        = 8;<br />         fixed_width  = true;<br />         color        = graphics_background;<br />         allow_accept = true;<br />       }<br />       :image_button<br />       {<br />         key = "UN";<br />         aspect_ratio = 1;<br />         width        = 8;<br />         fixed_width  = true;<br />         color        = graphics_background;<br />         allow_accept = true;<br />       }<br />       :image_button<br />       {<br />         key = "BS";<br />         aspect_ratio = 1;<br />         width        = 8;<br />         fixed_width  = true;<br />         color        = graphics_background;<br />         allow_accept = true;<br />       }<br />     }<br />     :list_box<br />     {<br />       key="RV";<br />       value=8;<br />       width=16;<br />       height=14;<br />       allow_accept=true;<br />     }<br />   }<br />   :errtile<br />   {<br />     width=18;<br />   }<br />   ok_cancel;<br /> }

1. (defun c:rough(/ scl value prcs DLG_ID llist
   
2.                p1u p2u p3u pcu ptu pqy
   
3.                p1d p2d p3d pcd ptd
   
4.                ename era erb dra drb
   
5.                snappnt nearpnt tag code ang
   
6.                max_x max_y do p00 ra rb
   
7.               )
   
8.   (defun do_list()
   
9.     (start_list "RV" 1)
   
10.     (setq value (nth (atoi $value) llist))
    
11.     (end_list)
    
12.     (set_tile "error" (strcat "粗糙度为 Ra" value))
    
13.   )
    
14.   (defun myerr(msg)
    
15.     (command "undo" "e")
    
16.     (setvar "osmode" os)
    
17.     (entdel ename)
    
18.     (setq *error* olderr)
    
19.   )
    
20.   (setvar "cmdecho" 0)
    
21.   (setq os (getvar "osmode"))
    
22.   (setq olderr *error*)
    
23.   (setq *error* myerr)
    
24.   (setvar "osmode" 0)
    
25.   (command "undo" "be")
    
26.   (setq scl (getvar "dimscale"))
    
27.   (setq value "3.2")
    
28.   (setq prcs 1)
    
29.   (setq DLG_ID (load_dialog "rough.dcl"))
    
30.   (new_dialog "roughness" DLG_ID)
    
31.   (start_image "RM")
    
32.   (setq max_x (dimx_tile "RM") max_y (dimy_tile "RM"))
    
33.   (slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(RM)"))
    
34.   (end_image)
    
35.   (start_image "UN")
    
36.   (setq max_x (dimx_tile "UN") max_y (dimy_tile "UN"))
    
37.   (slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(UN)"))
    
38.   (end_image)
    
39.   (start_image "BS")
    
40.   (setq max_x (dimx_tile "BS") max_y (dimy_tile "BS"))
    
41.   (slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(BS)"))
    
42.   (end_image)
    
43.   (setq llist '("" "0.025" "0.05" "0.1" "0.2" "0.4" "0.8" "1.6" "3.2" "6.3" "12.5" "25" "50"))
    
44.   (start_list "RV")
    
45.   (mapcar 'add_list llist)
    
46.   (end_list)
    
47.   (set_tile "RV" "8")
    
48.   (set_tile "error" (strcat "粗糙度为 Ra3.2"))
    
49.   (action_tile "RM" "(setq prcs 1)")
    
50.   (action_tile "UN" "(setq prcs 2)")
    
51.   (action_tile "BS" "(setq prcs 0)")
    
52.   (action_tile "RV" "(do_list)")
    
53.   (action_tile "accept" "(done_dialog 1)(setq do T)")
    
54.   (action_tile "cancel" "(done_dialog 0)")
    
55.   (start_dialog)
    
56.   (unload_dialog DLG_ID)
    
57.   (if do
    
58.     (progn
    
59.       (setq p00 '(0.0 0.0 0.0))
    
60.       (setq p1u '(2.3094 4.0 0.0))
    
61.       (setq p2u '(-2.3094 4.0 0.0))
    
62.       (setq p3u '(5.7735 10.0 0.0))
    
63.       (setq pcu '(0.0 2.67 0.0))
    
64.       (setq ptu '(0.0 6.5 0.0))
    
65.       (setq p1d '(-2.3094 -4.0 0.0))
    
66.       (setq p2d '(2.3094 -4.0 0.0))
    
67.       (setq p3d '(-5.7735 -10.0 0.0))
    
68.       (setq pcd '(0.0 -2.67 0.0))
    
69.       (setq ptd '(0.0 -6.5 0.0))
    
70.       (setq pqy '(-12.0 3.0 0.0))
    
71.       (create_ra)
    
72.       (create_rb)
    
73.       (entdel erb)
    
74.       (prompt "选择插入点")
    
75.       (setq ename era)
    
76.       (setq loop T)
    
77.       (while loop
    
78.         (setq code (grread T 8))
    
79.         (cond
    
80.           ((= (car code) 5)(do_move))
    
81.           ((= (car code) 3)(do_left))
    
82.           ((or (= (car code) 11)(= (car code) 25))(do_right))
    
83.           ((or (equal code '(2 97))(equal code'(2 65)))(do_a))
    
84.           ((or (equal code '(2 115))(equal code'(2 83)))(do_s))
    
85.         )
    
86.       )
    
87.     )
    
88.   )
    
89.   (setvar "osmode" os)
    
90.   (command "undo" "e")
    
91.   (setq *error* olderr)
    
92.   (princ)
    
93. )
    
94. (defun do_a()
    
95.   (setq value (cadr (member value llist)))
    
96.   (if value (progn (refresh ra)(refresh rb))(setq value "50"))
    
97. )
    
98. (defun do_s()
    
99.   (setq value (cadr (member value (reverse llist))))
    
100.   (if value (progn (refresh ra)(refresh rb))(setq value ""))
     
101. )
     
102. (defun refresh(bname / kname edata)
     
103.   (tblnext "block" T)
     
104.   (while (/= (cdr (assoc 2 (setq kname (tblnext "block")))) bname))
     
105.   (setq edata (entget (cdr (assoc -2 kname))))
     
106.   (entmod (subst (cons 1 value)(assoc 1 edata) edata))
     
107.   (entupd ename)
     
108. )
     
109. (defun create_ra()
     
110.   (entmake (list '(0 . "BLOCK")'(10 0 0 0)'(70 . 1)'(2 . "*U")))
     
111.   (entmake (list '(0 . "TEXT")(cons 10 p00)(cons 11 ptu)'(8 . "DIM")'(40 . 2.5)'(62 . 3)'(72 . 4)(cons 1 value)))
     
112.   (cond
     
113.     ((= prcs 1)(entmake (list '(0 . "LINE")(cons 10 p1u)(cons 11 p2u)'(8 . "DIM"))))
     
114.     ((= prcs 2)(entmake (list '(0 . "CIRCLE")(cons 10 pcu)'(40 . 1.33)'(8 . "DIM"))))
     
115.   )
     
116.   (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p2u)'(8 . "DIM")))
     
117.   (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p3u)'(8 . "DIM")))
     
118.   (setq ra (entmake '((0 . "ENDBLK"))))
     
119.   (entmake (list '(0 . "INSERT")(cons 10 p00)(cons 41 scl)(cons 42 scl)(cons 2 ra)))
     
120.   (setq era (entlast))
     
121.   (setq dra (entget era))
     
122. )
     
123. (defun create_rb()
     
124.   (entmake (list '(0 . "BLOCK")'(10 0 0 0)'(70 . 1)'(2 . "*U")))
     
125.   (entmake (list '(0 . "TEXT")(cons 10 p00)(cons 11 ptd)'(8 . "DIM")'(40 . 2.5)'(62 . 3)'(72 . 4)(cons 1 value)))
     
126.   (cond
     
127.     ((= prcs 1)(entmake (list '(0 . "LINE")(cons 10 p1d)(cons 11 p2d)'(8 . "DIM"))))
     
128.     ((= prcs 2)(entmake (list '(0 . "CIRCLE")(cons 10 pcd)'(40 . 1.33)'(8 . "DIM"))))
     
129.   )
     
130.   (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p2d)'(8 . "DIM")))
     
131.   (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p3d)'(8 . "DIM")))
     
132.   (setq rb (entmake '((0 . "ENDBLK"))))
     
133.   (entmake (list '(0 . "INSERT")(cons 10 p00)(cons 41 scl)(cons 42 scl)(cons 2 rb)))
     
134.   (setq erb (entlast))
     
135.   (setq drb (entget erb))
     
136. )
     
137. (defun do_left()
     
138.   (setq snappnt (cadr code))
     
139.   (entdel ename)
     
140.   (if (osnap snappnt "nea")
     
141.     (progn
     
142.       (entdel ename)
     
143.       (create_ra)
     
144.       (create_rb)
     
145.       (entdel erb)
     
146.       (setq ename era)
     
147.     )
     
148.     (progn
     
149.       (entdel ename)
     
150.       (setq dra (subst (cons 50 0.0)(assoc 50 dra) dra))
     
151.       (setq dra (subst (cons 41 (* 1.25 (cdr (assoc 41 dra))))(assoc 41 dra) dra))
     
152.       (setq dra (subst (cons 42 (* 1.25 (cdr (assoc 42 dra))))(assoc 42 dra) dra))
     
153.       (entmod dra)
     
154.       (entmake (list '(0 . "TEXT")'(8 . "DIM")'(10 0.0 0.0 0.0)(cons 40 (* scl 5.0))'(62 . 3)'(72 . 4)(cons 11 (mapcar '+ (mapcar (function (lambda (x)(* scl x))) pqy) snappnt))'(1 . "其余")))
     
155.       (setq loop nil)
     
156.     )
     
157.   )
     
158. )
     
159. (defun do_right()
     
160.   (setq loop nil)
     
161.   (entdel ename)
     
162. )
     
163. (defun do_move()
     
164.   (setq snappnt (cadr code))
     
165.   (entdel ename)
     
166.   (setq nearpnt (osnap snappnt "nea"))
     
167.   (if nearpnt
     
168.     (progn
     
169.       (setq ang (angle nearpnt snappnt))
     
170.       (cond
     
171.         (
     
172.           (and (>= ang (/ pi 6.0))(<= ang pi))
     
173.           (setq ang (- ang (/ pi 2.0)))
     
174.           (entdel era)
     
175.           (setq ename era)
     
176.           (setq dra (subst (cons 10 nearpnt)(assoc 10 dra) dra))
     
177.           (setq nearpnt nil)
     
178.           (setq dra (subst (cons 50 ang)(assoc 50 dra) dra))
     
179.           (entmod dra)
     
180.         )
     
181.         (
     
182.           (or (= ang 0.0)(and (> ang (* (/ pi 6.0) 7.0))(< ang (* pi 2.0))))
     
183.           (setq ang (+ ang (/ pi 2.0)))
     
184.           (entdel erb)
     
185.           (setq ename erb)
     
186.           (setq drb (subst (cons 10 nearpnt)(assoc 10 drb) drb))
     
187.           (setq nearpnt nil)
     
188.           (setq drb (subst (cons 50 ang)(assoc 50 drb) drb))
     
189.           (entmod drb)
     
190.         )
     
191.         (T
     
192.           (entdel era)
     
193.           (setq ename era)
     
194.           (setq nearpnt nil)
     
195.         )
     
196.       )
     
197.     )
     
198.     (progn
     
199.       (entdel era)
     
200.       (setq ename era)
     
201.       (setq dra (subst (cons 10 snappnt)(assoc 10 dra) dra))
     
202.       (setq dra (subst (cons 50 0.0)(assoc 50 dra) dra))
     
203.       (entmod dra)
     
204.       (setq nearpnt nil)
     
205.     )
     
206.   )
     
207. )

(defun c:rough(/ scl value prcs DLG_ID llist<br />                p1u p2u p3u pcu ptu pqy<br />                p1d p2d p3d pcd ptd<br />                ename era erb dra drb<br />                snappnt nearpnt tag code ang<br />                max_x max_y do p00 ra rb<br />               )<br />   (defun do_list()<br />     (start_list "RV" 1)<br />     (setq value (nth (atoi $value) llist))<br />     (end_list)<br />     (set_tile "error" (strcat "粗糙度为 Ra" value))<br />   )<br />   (defun myerr(msg)<br />     (command "undo" "e")<br />     (setvar "osmode" os)<br />     (entdel ename)<br />     (setq *error* olderr)<br />   )<br />   (setvar "cmdecho" 0)<br />   (setq os (getvar "osmode"))<br />   (setq olderr *error*)<br />   (setq *error* myerr)<br />   (setvar "osmode" 0)<br />   (command "undo" "be")<br />   (setq scl (getvar "dimscale"))<br />   (setq value "3.2")<br />   (setq prcs 1)<br />   (setq DLG_ID (load_dialog "rough.dcl"))<br />   (new_dialog "roughness" DLG_ID)<br />   (start_image "RM")<br />   (setq max_x (dimx_tile "RM") max_y (dimy_tile "RM"))<br />   (slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(RM)"))<br />   (end_image)<br />   (start_image "UN")<br />   (setq max_x (dimx_tile "UN") max_y (dimy_tile "UN"))<br />   (slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(UN)"))<br />   (end_image)<br />   (start_image "BS")<br />   (setq max_x (dimx_tile "BS") max_y (dimy_tile "BS"))<br />   (slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(BS)"))<br />   (end_image)<br />   (setq llist '("" "0.025" "0.05" "0.1" "0.2" "0.4" "0.8" "1.6" "3.2" "6.3" "12.5" "25" "50"))<br />   (start_list "RV")<br />   (mapcar 'add_list llist) <br />   (end_list)<br />   (set_tile "RV" "8")<br />   (set_tile "error" (strcat "粗糙度为 Ra3.2"))<br />   (action_tile "RM" "(setq prcs 1)")<br />   (action_tile "UN" "(setq prcs 2)")<br />   (action_tile "BS" "(setq prcs 0)")<br />   (action_tile "RV" "(do_list)")<br />   (action_tile "accept" "(done_dialog 1)(setq do T)")<br />   (action_tile "cancel" "(done_dialog 0)")<br />   (start_dialog)<br />   (unload_dialog DLG_ID)<br />   (if do<br />     (progn<br />       (setq p00 '(0.0 0.0 0.0))<br />       (setq p1u '(2.3094 4.0 0.0))<br />       (setq p2u '(-2.3094 4.0 0.0))<br />       (setq p3u '(5.7735 10.0 0.0))<br />       (setq pcu '(0.0 2.67 0.0))<br />       (setq ptu '(0.0 6.5 0.0))<br />       (setq p1d '(-2.3094 -4.0 0.0))<br />       (setq p2d '(2.3094 -4.0 0.0))<br />       (setq p3d '(-5.7735 -10.0 0.0))<br />       (setq pcd '(0.0 -2.67 0.0))<br />       (setq ptd '(0.0 -6.5 0.0))<br />       (setq pqy '(-12.0 3.0 0.0))<br />       (create_ra)<br />       (create_rb)<br />       (entdel erb)<br />       (prompt "选择插入点")<br />       (setq ename era)<br />       (setq loop T)<br />       (while loop<br />         (setq code (grread T 8))<br />         (cond<br />           ((= (car code) 5)(do_move))<br />           ((= (car code) 3)(do_left))<br />           ((or (= (car code) 11)(= (car code) 25))(do_right))<br />           ((or (equal code '(2 97))(equal code'(2 65)))(do_a))<br />           ((or (equal code '(2 115))(equal code'(2 83)))(do_s))<br />         )<br />       )<br />     )<br />   )<br />   (setvar "osmode" os)<br />   (command "undo" "e")<br />   (setq *error* olderr)<br />   (princ)<br /> )<br /> (defun do_a()<br />   (setq value (cadr (member value llist)))<br />   (if value (progn (refresh ra)(refresh rb))(setq value "50"))<br /> )<br /> (defun do_s()<br />   (setq value (cadr (member value (reverse llist))))<br />   (if value (progn (refresh ra)(refresh rb))(setq value ""))<br /> )<br /> (defun refresh(bname / kname edata)<br />   (tblnext "block" T)<br />   (while (/= (cdr (assoc 2 (setq kname (tblnext "block")))) bname))<br />   (setq edata (entget (cdr (assoc -2 kname))))<br />   (entmod (subst (cons 1 value)(assoc 1 edata) edata))<br />   (entupd ename)<br /> )<br /> (defun create_ra()<br />   (entmake (list '(0 . "BLOCK")'(10 0 0 0)'(70 . 1)'(2 . "*U")))<br />   (entmake (list '(0 . "TEXT")(cons 10 p00)(cons 11 ptu)'(8 . "DIM")'(40 . 2.5)'(62 . 3)'(72 . 4)(cons 1 value)))<br />   (cond<br />     ((= prcs 1)(entmake (list '(0 . "LINE")(cons 10 p1u)(cons 11 p2u)'(8 . "DIM"))))<br />     ((= prcs 2)(entmake (list '(0 . "CIRCLE")(cons 10 pcu)'(40 . 1.33)'(8 . "DIM"))))<br />   )<br />   (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p2u)'(8 . "DIM")))<br />   (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p3u)'(8 . "DIM")))<br />   (setq ra (entmake '((0 . "ENDBLK"))))<br />   (entmake (list '(0 . "INSERT")(cons 10 p00)(cons 41 scl)(cons 42 scl)(cons 2 ra)))<br />   (setq era (entlast))<br />   (setq dra (entget era))<br /> )<br /> (defun create_rb()<br />   (entmake (list '(0 . "BLOCK")'(10 0 0 0)'(70 . 1)'(2 . "*U")))<br />   (entmake (list '(0 . "TEXT")(cons 10 p00)(cons 11 ptd)'(8 . "DIM")'(40 . 2.5)'(62 . 3)'(72 . 4)(cons 1 value)))<br />   (cond<br />     ((= prcs 1)(entmake (list '(0 . "LINE")(cons 10 p1d)(cons 11 p2d)'(8 . "DIM"))))<br />     ((= prcs 2)(entmake (list '(0 . "CIRCLE")(cons 10 pcd)'(40 . 1.33)'(8 . "DIM"))))<br />   )<br />   (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p2d)'(8 . "DIM")))<br />   (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p3d)'(8 . "DIM")))<br />   (setq rb (entmake '((0 . "ENDBLK"))))<br />   (entmake (list '(0 . "INSERT")(cons 10 p00)(cons 41 scl)(cons 42 scl)(cons 2 rb)))<br />   (setq erb (entlast))<br />   (setq drb (entget erb))<br /> )<br /> (defun do_left()<br />   (setq snappnt (cadr code))<br />   (entdel ename)<br />   (if (osnap snappnt "nea")<br />     (progn<br />       (entdel ename)<br />       (create_ra)<br />       (create_rb)<br />       (entdel erb)<br />       (setq ename era)<br />     )<br />     (progn<br />       (entdel ename)<br />       (setq dra (subst (cons 50 0.0)(assoc 50 dra) dra))<br />       (setq dra (subst (cons 41 (* 1.25 (cdr (assoc 41 dra))))(assoc 41 dra) dra))<br />       (setq dra (subst (cons 42 (* 1.25 (cdr (assoc 42 dra))))(assoc 42 dra) dra))<br />       (entmod dra)<br />       (entmake (list '(0 . "TEXT")'(8 . "DIM")'(10 0.0 0.0 0.0)(cons 40 (* scl 5.0))'(62 . 3)'(72 . 4)(cons 11 (mapcar '+ (mapcar (function (lambda (x)(* scl x))) pqy) snappnt))'(1 . "其余")))<br />       (setq loop nil)<br />     )<br />   )<br /> )<br /> (defun do_right()<br />   (setq loop nil)<br />   (entdel ename)<br /> )<br /> (defun do_move()<br />   (setq snappnt (cadr code))<br />   (entdel ename)<br />   (setq nearpnt (osnap snappnt "nea"))<br />   (if nearpnt<br />     (progn<br />       (setq ang (angle nearpnt snappnt))<br />       (cond<br />         (<br />           (and (>= ang (/ pi 6.0))(<= ang pi))<br />           (setq ang (- ang (/ pi 2.0)))<br />           (entdel era)<br />           (setq ename era)<br />           (setq dra (subst (cons 10 nearpnt)(assoc 10 dra) dra))<br />           (setq nearpnt nil)<br />           (setq dra (subst (cons 50 ang)(assoc 50 dra) dra))<br />           (entmod dra)<br />         )<br />         (<br />           (or (= ang 0.0)(and (> ang (* (/ pi 6.0) 7.0))(< ang (* pi 2.0))))<br />           (setq ang (+ ang (/ pi 2.0)))<br />           (entdel erb)<br />           (setq ename erb)<br />           (setq drb (subst (cons 10 nearpnt)(assoc 10 drb) drb))<br />           (setq nearpnt nil)<br />           (setq drb (subst (cons 50 ang)(assoc 50 drb) drb))<br />           (entmod drb)<br />         )<br />         (T<br />           (entdel era)<br />           (setq ename era)<br />           (setq nearpnt nil)<br />         )<br />       )<br />     )<br />     (progn<br />       (entdel era)<br />       (setq ename era)<br />       (setq dra (subst (cons 10 snappnt)(assoc 10 dra) dra))<br />       (setq dra (subst (cons 50 0.0)(assoc 50 dra) dra))<br />       (entmod dra)<br />       (setq nearpnt nil)<br />     )<br />   )<br /> )

命令：rough
按a键数值增加，按s键数值减少

langjs

这个程序真好用，加入我的工具箱了。修改了一下，把幻灯片和对话框整合到sp里了

;;;; ****************************************************************
;;; *风之影粗糙度绘制，langjs修改
;;; ****************************************************************
(defun c:ccd (/ $value a ang b bname c code dcl_pt dcl_re dclname do dra drb edata ename era erb f kname llist loop myerr
                nearpnt olderr os p00 p1d p1u p2d p2u p3d p3u pcd pcu pqy prcs ptd ptu ra rb scl snappnt value x
             )
  (defun do_list ()
    (start_list "RV" 1)
    (setq value (nth (atoi $value) llist))
    (end_list)
    (set_tile "error" (strcat "粗糙度为 Ra" value))
  )
  (defun myerr (msg)
    (command "undo" "e")
    (setvar "osmode" os)
    (entdel ename)
    (setq *error* olderr)
  )
  (defun image (a b c)
    (if (= a 0)
      (progn
        (start_image "RM")
        (fill_image 0 0 48 48 4)
        (vector_image 20 40 40 5 5)
        (vector_image 20 40 12 26 5)
        (vector_image 28 26 12 26 5)
        (vector_image 20 41 40 6 5)
        (vector_image 20 41 12 27 5)
        (vector_image 28 27 12 27 5)
        (end_image)
      )
      (progn
        (start_image "RM")
        (fill_image 0 0 48 48 5)
        (vector_image 20 40 40 5 7)
        (vector_image 20 40 12 26 7)
        (vector_image 28 26 12 26 7)
        (vector_image 20 41 40 6 7)
        (vector_image 20 41 12 27 7)
        (vector_image 28 27 12 27 7)
        (end_image)
      )
    )
    (if (= b 0)
      (progn
        (start_image "UN")
        (fill_image 0 0 48 48 4)
        (vector_image 20 40 40 5 5)
        (vector_image 20 40 12 26 5)
        (vector_image 20 41 40 6 5)
        (vector_image 20 41 12 27 5)
        (vector_image 18 26 23 26 5)
        (vector_image 17 27 18 27 5)
        (vector_image 23 27 24 27 5)
        (vector_image 16 28 17 28 5)
        (vector_image 24 28 25 28 5)
        (vector_image 16 29 16 32 5)
        (vector_image 25 29 25 32 5)
        (vector_image 16 33 17 33 5)
        (vector_image 24 33 25 33 5)
        (vector_image 17 34 18 34 5)
        (vector_image 23 34 24 34 5)
        (vector_image 18 35 23 35 5)
        (end_image)
      )
      (progn
        (start_image "UN")
        (fill_image 0 0 48 48 5)
        (vector_image 20 40 40 5 7)
        (vector_image 20 40 12 26 7)
        (vector_image 20 41 40 6 7)
        (vector_image 20 41 12 27 7)
        (vector_image 18 26 23 26 7)
        (vector_image 17 27 18 27 7)
        (vector_image 23 27 24 27 7)
        (vector_image 16 28 17 28 7)
        (vector_image 24 28 25 28 7)
        (vector_image 16 29 16 32 7)
        (vector_image 25 29 25 32 7)
        (vector_image 16 33 17 33 7)
        (vector_image 24 33 25 33 7)
        (vector_image 17 34 18 34 7)
        (vector_image 23 34 24 34 7)
        (vector_image 18 35 23 35 7)
        (end_image)
      )
    )
    (if (= c 0)
      (progn
        (start_image "BS")
        (fill_image 0 0 48 48 4)
        (vector_image 20 40 40 5 5)
        (vector_image 20 40 12 26 5)
        (vector_image 20 41 40 6 5)
        (vector_image 20 41 12 27 5)
        (end_image)
      )
      (progn
        (start_image "BS")
        (fill_image 0 0 48 48 5)
        (vector_image 20 40 40 5 7)
        (vector_image 20 40 12 26 7)
        (vector_image 20 41 40 6 7)
        (vector_image 20 41 12 27 7)
        (end_image)
      )
    )
  )
  (defun do_a ()
    (setq value (cadr (member value llist)))
    (if value
      (progn
        (refresh ra)
        (refresh rb)
      )
      (setq value "50")
    )
  )
  (defun do_s ()
    (setq value (cadr (member value (reverse llist))))
    (if value
      (progn
        (refresh ra)
        (refresh rb)
      )
      (setq value "")
    )
  )
  (defun refresh (bname / kname edata)
    (tblnext "block" t)
    (while (/= (cdr (assoc 2 (setq kname (tblnext "block")))) bname))
    (setq edata (entget (cdr (assoc -2 kname))))
    (entmod (subst
              (cons 1 value)
              (assoc 1 edata)
              edata
            )
    )
    (entupd ename)
  )
  (defun create_ra ()
    (entmake (list '(0 . "BLOCK") '(10 0 0 0) '(70 . 1) '(2 . "*U")))
    (entmake (list '(0 . "TEXT") (cons 10 p00) (cons 11 ptu) (cons 7 (getvar "DIMTXSTY")) '(8 . "DIM") '(40 . 2.5) '
                   (62 . 3) '(72 . 4) (cons 1 value)
             )
    )
    (cond
      ((= prcs 1)
        (entmake (list '(0 . "LINE") '(62 . 4) (cons 10 p1u) (cons 11 p2u) '(8 . "DIM")))
      )
      ((= prcs 2)
        (entmake (list '(0 . "CIRCLE") '(62 . 4) (cons 10 pcu) '(40 . 1.33) '(8 . "DIM")))
      )
    )
    (entmake (list '(0 . "LINE") '(62 . 4) (cons 10 p00) (cons 11 p2u) '(8 . "DIM")))
    (entmake (list '(0 . "LINE") '(62 . 4) (cons 10 p00) (cons 11 p3u) '(8 . "DIM")))
    (setq ra (entmake '((0 . "ENDBLK"))))
    (entmake (list '(0 . "INSERT") (cons 10 p00) (cons 41 scl) (cons 42 scl) (cons 2 ra)))
    (setq era (entlast))
    (setq dra (entget era))
  )
  (defun create_rb ()
    (entmake (list '(0 . "BLOCK") '(10 0 0 0) '(70 . 1) '(2 . "*U")))
    (entmake (list '(0 . "TEXT") (cons 10 p00) (cons 11 ptd) (cons 7 (getvar "DIMTXSTY")) '(8 . "DIM") '(40 . 2.5) '
                   (62 . 3) '(72 . 4) (cons 1 value)
             )
    )
    (cond
      ((= prcs 1)
        (entmake (list '(0 . "LINE") '(62 . 4) (cons 10 p1d) (cons 11 p2d) '(8 . "DIM")))
      )
      ((= prcs 2)
        (entmake (list '(0 . "CIRCLE") '(62 . 4) (cons 10 pcd) '(40 . 1.33) '(8 . "DIM")))
      )
    )
    (entmake (list '(0 . "LINE") '(62 . 4) (cons 10 p00) (cons 11 p2d) '(8 . "DIM")))
    (entmake (list '(0 . "LINE") '(62 . 4) (cons 10 p00) (cons 11 p3d) '(8 . "DIM")))
    (setq rb (entmake '((0 . "ENDBLK"))))
    (entmake (list '(0 . "INSERT") (cons 10 p00) (cons 41 scl) (cons 42 scl) (cons 2 rb)))
    (setq erb (entlast))
    (setq drb (entget erb))
  )
  (defun do_left ()
    (setq snappnt (cadr code))
    (entdel ename)
    (if (osnap snappnt "nea")
      (progn
        (entdel ename)
        (create_ra)
        (create_rb)
        (entdel erb)
        (setq ename era)
      )
      (progn
        (entdel ename)
        (setq dra (subst
                    (cons 50 0.0)
                    (assoc 50 dra)
                    dra
                  )
        )
        (setq dra (subst
                    (cons 41 (* 1.25 (cdr (assoc 41 dra))))
                    (assoc 41 dra)
                    dra
                  )
        )
        (setq dra (subst
                    (cons 42 (* 1.25 (cdr (assoc 42 dra))))
                    (assoc 42 dra)
                    dra
                  )
        )
        (entmod dra)
        (entmake (list '(0 . "TEXT") (cons 7 (getvar "DIMTXSTY")) '(8 . "DIM") '(10 0.0 0.0 0.0) (cons 40 (* scl 4.0))
                       (cons 41 0.8) '(62 . 3) '(72 . 4) (cons 11 (mapcar
                                                                    '+
                                                                    (mapcar
                                                                      (function (lambda (x)
                                                                                  (* scl x)
                                                                                )
                                                                      )
                                                                      pqy
                                                                    )
                                                                    snappnt
                                                                  )
                                                         ) '(1 . "其余")
                 )
        )
        (setq loop nil)
      )
    )
  )
  (defun do_right ()
    (setq loop nil)
    (entdel ename)
  )
  (defun do_move ()
    (setq snappnt (cadr code))
    (entdel ename)
    (setq nearpnt (osnap snappnt "nea"))
    (if nearpnt
      (progn
        (setq ang (angle nearpnt snappnt))
        (cond
          ((and
             (>= ang (/ pi 6.0))
             (<= ang pi)
           )
            (setq ang (- ang (/ pi 2.0)))
            (entdel era)
            (setq ename era)
            (setq dra (subst
                        (cons 10 nearpnt)
                        (assoc 10 dra)
                        dra
                      )
            )
            (setq nearpnt nil)
            (setq dra (subst
                        (cons 50 ang)
                        (assoc 50 dra)
                        dra
                      )
            )
            (entmod dra)
          )
          ((or
             (= ang 0.0)
             (and
               (> ang (* (/ pi 6.0) 7.0))
               (< ang (* pi 2.0))
             )
           )
            (setq ang (+ ang (/ pi 2.0)))
            (entdel erb)
            (setq ename erb)
            (setq drb (subst
                        (cons 10 nearpnt)
                        (assoc 10 drb)
                        drb
                      )
            )
            (setq nearpnt nil)
            (setq drb (subst
                        (cons 50 ang)
                        (assoc 50 drb)
                        drb
                      )
            )
            (entmod drb)
          )
          (t
            (entdel era)
            (setq ename era)
            (setq nearpnt nil)
          )
        )
      )
      (progn
        (entdel era)
        (setq ename era)
        (setq dra (subst
                    (cons 10 snappnt)
                    (assoc 10 dra)
                    dra
                  )
        )
        (setq dra (subst
                    (cons 50 0.0)
                    (assoc 50 dra)
                    dra
                  )
        )
        (entmod dra)
        (setq nearpnt nil)
      )
    )
  )
  (setvar "cmdecho" 0)
  (vl-load-com)
  (setq os (getvar "osmode"))
  (setq olderr *error*)
  (setq *error* myerr)
  (setvar "osmode" 0)
  (command "undo" "be")
  (setq scl (getvar "dimscale"))
  (setq value "3.2")
  (setq prcs 1)
  (setq dclname (vl-filename-mktemp "rough.dcl")
        f (open dclname "w")
  )
  (write-line "roughness:dialog{ label=\"风之影粗糙度\"; spacer; " f)
  (write-line " :row { :column {  " f)
  (write-line ":image_button { key = \"RM\"; aspect_ratio = 1; width = 8; fixed_width = true; color = graphics_background; allow_accept = true; }"
              f
  )
  (write-line ":image_button { key = \"UN\"; aspect_ratio = 1; width = 8; fixed_width = true; color = graphics_background; allow_accept = true; } "
              f
  )
  (write-line ":image_button { key = \"BS\"; aspect_ratio = 1; width = 8; fixed_width = true; color = graphics_background; allow_accept = true; } } "
              f
  )
  (write-line ":list_box { key=\"RV\"; value=8; width=16; height=14; allow_accept=true; } } " f)
  (write-line ":errtile { width=18; } ok_cancel;}" f)
  (close f)
  (setq dcl_re (load_dialog dclname))
  (new_dialog "roughness" dcl_re "" dcl_pt)
  (setq llist '("" "0.025"
         "0.05" "0.1"
         "0.2" "0.4"
         "0.8" "1.6"
         "3.2" "6.3"
         "12.5" "25"
         "50"
        )
  )
  (start_list "RV")
  (mapcar
    'add_list
    llist
  )
  (end_list)
  (image 0 0 0)
  (set_tile "RV" "8")
  (set_tile "error" (strcat "粗糙度为 Ra3.2"))
  (action_tile "RM" "(image 1 0 0) (setq prcs 1)")
  (action_tile "UN" "(image 0 1 0)  (setq prcs 2)")
  (action_tile "BS" "(image 0 0 1)  (setq prcs 0)")
  (action_tile "RV" "(do_list)")
  (action_tile "accept" "(done_dialog 1)(setq do T)")
  (action_tile "cancel" "(done_dialog 0)")
  (start_dialog)
  (unload_dialog dcl_re)
  (vl-file-delete dclname)
  (if do
    (progn
      (setq p00 '(0.0 0.0 0.0))
      (setq p1u '(2.3094 4.0 0.0))
      (setq p2u '(-2.3094 4.0 0.0))
      (setq p3u '(5.7735 10.0 0.0))
      (setq pcu '(0.0 2.67 0.0))
      (setq ptu '(0.0 6.5 0.0))
      (setq p1d '(-2.3094 -4.0 0.0))
      (setq p2d '(2.3094 -4.0 0.0))
      (setq p3d '(-5.7735 -10.0 0.0))
      (setq pcd '(0.0 -2.67 0.0))
      (setq ptd '(0.0 -6.5 0.0))
      (setq pqy '(-9.0 3.0 0.0))
      (create_ra)
      (create_rb)
      (entdel erb)
      (prompt "\n选择插入点，[A键]增加，[S键]减小：")
      (setq ename era)
      (setq loop t)
      (while loop
        (setq code (grread t 15 0))
        (cond
          ((= (car code) 5)
            (do_move)
          )
          ((= (car code) 3)
            (do_left)
          )
          ((or
             (= (car code) 11)
             (= (car code) 25)
           )
            (do_right)
          )
          ((or
             (equal code '(2 97))
             (equal code' (2 65))
           )
            (do_a)
          )
          ((or
             (equal code '(2 115))
             (equal code' (2 83))
           )
            (do_s)
          )
        )
      )
    )
  )
  (setvar "osmode" os)
  (command "undo" "e")
  (setq *error* olderr)
  (princ)
)

ninja37

楼主的工具 总是那么实用  都是精品

cabinsummer

程序提前在我的群200499529中共享。

crtrccrt

好程序
一个字
很好

仲文玉

支持风之影
群：200499529已满，可加入新超级群：62555795

669423907

好强劲的风啊！

669423907

字高如果能为当前标注样式的字体与字高是不是会更完美些呢？

laoqian123

强，程序很人性化了

jfxia

      楼主，我加载你的程序经常列死机，不知怎么回事



  抱歉，，不好意思，是因为找不到SLB文件，所以死机

          但如找不到能自动中断就好点，

            谢楼主分享

cabinsummer

jfxia 发表于 2012-1-5 20:16
楼主，我加载你的程序经常列死机，不知怎么回事

源码都给你了。别人用都没问题，好好检查一下自己的CAD

crtrccrt

一个字
好程序
很好用