急寻一个画中心线的好方法或程序

qyr_0_0

急寻一个画中心线的好方法或程序！谢过！

Block

2. ;;--------------=={ Associative Centerlines }==---------------;;
   
3. 
   
4. (defun c:cl ( / _line ss e c r l1 l2 )
   
5.   (if
   
6.     (and
   
7.       (setq ss
   
8.         (ssget
   
9.           (list '(0 . "CIRCLE") '(-4 . "<NOT") (list -3 (list cl:app)) '(-4 . "NOT>"))
   
10.         )
    
11.       )
    
12.       (or (tblsearch "APPID" cl:app) (regapp cl:app))
    
13.     )
    
14.     (progn
    
15.       (defun _line ( p1 p2 h )
    
16.         (entmakex
    
17.           (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)
    
18.             (list -3
    
19.               (list cl:app
    
20.                 (cons 1002 "{") (cons 1005 h) (cons 1002 "}")
    
21.               )
    
22.             )
    
23.           )
    
24.         )
    
25.       )
    
26.       (repeat (setq i (sslength ss))
    
27.         (setq e  (entget (ssname ss (setq i (1- i))))
    
28.               h  (cdr (assoc  5 e))
    
29.               c  (cdr (assoc 10 e))
    
30.               r  (* cl:ratio (cdr (assoc 40 e)))
    
31.               l1 (_line (polar c 0. r) (polar c pi r) h)
    
32.               l2 (_line (polar c (/ pi 2.) r) (polar c (/ (* 3. pi) 2.) r) h)
    
33.         )
    
34.         (entmod
    
35.           (list (assoc -1 e)
    
36.             (list -3
    
37.               (list cl:app
    
38.                 (cons 1002 "{")
    
39.                 (cons 1005 (cdr (assoc 5 (entget l1))))
    
40.                 (cons 1005 (cdr (assoc 5 (entget l2))))
    
41.                 (cons 1002 "}")
    
42.               )
    
43.             )
    
44.           )
    
45.         )
    
46.         (vlr-object-reactor (list (vlax-ename->vla-object (cdr (assoc -1 e)))) (list cl:app h)
    
47.           (list
    
48.             (cons :vlr-modified 'cl:circle:callback)
    
49.           )
    
50.         )
    
51.         (vlr-object-reactor (mapcar 'vlax-ename->vla-object (list l1 l2)) (list cl:app h)
    
52.           (list
    
53.             (cons :vlr-modified 'cl:line:callback)
    
54.           )
    
55.         )
    
56.       )
    
57.     )
    
58.   )
    
59.   (princ)
    
60. )
    
61. 
    
62. ;;------------------------------------------------------------;;
    
63. 
    
64. (defun c:clremove ( / _massoc ss fl i e r d h x )
    
65. 
    
66.   (defun _massoc ( x l )
    
67.     (if (setq a (assoc x l))
    
68.       (cons (cdr a) (_massoc x (cdr (member a l))))
    
69.     )
    
70.   )
    
71.   
    
72.   (princ "\nSelect Circles to Remove Associativity <All>: ")
    
73.   (setq fl (list '(0 . "CIRCLE") (list -3 (list cl:app))) i -1)
    
74.   
    
75.   (if
    
76.     (setq ss
    
77.       (cond
    
78.         ( (ssget fl) )
    
79.         ( (ssget "_X" fl) )
    
80.       )
    
81.     )
    
82.     (while (setq e (ssname ss (setq i (1+ i)))) (setq e (entget e (list cl:app)))
    
83.       (foreach r (cdar (vlr-reactors :vlr-object-reactor))
    
84.         (if
    
85.           (and
    
86.             (setq d (vlr-data r))
    
87.             (listp d)
    
88.             (eq cl:app (car d))
    
89.             (or (not (cadr d)) (eq (cdr (assoc 5 e)) (cadr d)))
    
90.           )
    
91.           (vlr-remove r)
    
92.         )
    
93.       )
    
94.       (foreach h (_massoc 1005 (cdadr (assoc -3 e)))
    
95.         (if (setq x (entget (handent h)))
    
96.           (entmod (list (assoc -1 x) (list -3 (list cl:app))))
    
97.         )
    
98.       )
    
99.       (entmod (list (assoc -1 e) (list -3 (list cl:app))))
    
100.     )
     
101.   )
     
102.   (princ)
     
103. )      
     
104. 
     
105. ;;------------------------------------------------------------;;
     
106. 
     
107. (defun cl:circle:callback ( owner reactor params / xtyp xval c r )
     
108.   (if
     
109.     (and
     
110.       (vlax-read-enabled-p owner)
     
111.       (progn (vla-getxdata owner cl:app 'xtyp 'xval) xval)
     
112.       (setq
     
113.         c (vlax-get owner 'center)
     
114.         r (* cl:ratio (vlax-get owner 'radius))
     
115.       )
     
116.     )
     
117.     (mapcar
     
118.       (function
     
119.         (lambda ( h a )
     
120.           (if (or (entget (setq h (handent h))) (entdel h))
     
121.             (entmod
     
122.               (list (cons -1 h) (cons 10 (polar c a r)) (cons 11 (polar c (+ a pi) r)))
     
123.             )
     
124.           )
     
125.         )
     
126.       )
     
127.       (cddr (mapcar 'vlax-variant-value (vlax-safearray->list xval))) (list 0. (/ pi 2.))
     
128.     )
     
129.   )
     
130.   (princ)
     
131. )
     
132. 
     
133. ;;------------------------------------------------------------;;
     
134. 
     
135. (defun cl:line:callback ( owner reactor params )
     
136.   (setq *data (list owner reactor))
     
137.   (vlr-command-reactor (list cl:app)
     
138.     (list
     
139.       (cons :vlr-commandended     'cl:line:modify)
     
140.       (cons :vlr-commandcancelled 'cl:line:cancelled)
     
141.       (cons :vlr-commandfailed    'cl:line:cancelled)
     
142.     )
     
143.   )
     
144.   (vlr-remove reactor)
     
145.   (princ)  
     
146. )
     
147. 
     
148. ;;------------------------------------------------------------;;
     
149. 
     
150. (defun cl:line:modify ( reactor params / xtyp xval h ) (vlr-remove reactor)
     
151.   (if
     
152.     (and *data (not (vlax-erased-p (car *data))) (progn (vla-getxdata (car *data) cl:app 'xtyp 'xval) xval)   
     
153.       (or
     
154.         (entget
     
155.           (setq h
     
156.             (handent
     
157.               (caddr
     
158.                 (mapcar 'vlax-variant-value (vlax-safearray->list xval))
     
159.               )
     
160.             )
     
161.           )
     
162.         )
     
163.         (entdel h)
     
164.       )
     
165.     )
     
166.     (progn
     
167.       (cl:circle:callback (vlax-ename->vla-object h) nil nil)
     
168.       (vlr-add (cadr *data))
     
169.       (setq *data nil)
     
170.     )
     
171.   )   
     
172.   (princ)
     
173. )
     
174. 
     
175. ;;------------------------------------------------------------;;
     
176. 
     
177. (defun cl:line:cancelled ( reactor params ) (vlr-remove reactor)
     
178.   (if *data
     
179.     (progn
     
180.       (vlr-add (cadr *data))
     
181.       (setq *data nil)
     
182.     )
     
183.   )
     
184.   (princ)
     
185. )
     
186. 
     
187. ;;------------------------------------------------------------;;
     
188. 
     
189. (
     
190.   (lambda ( / r d s i e o xtyp xval )
     
191.     (foreach r (cdar (vlr-reactors :vlr-object-reactor))
     
192.       (if (and (setq d (vlr-data r)) (listp d) (eq cl:app (car d)))
     
193.         (vlr-remove r)
     
194.       )
     
195.     )
     
196.     (if (setq s (ssget "_X" (list '(0 . "CIRCLE") (list -3 (list cl:app)))))
     
197.       (repeat (setq i (sslength s))
     
198.         (setq e (ssname s (setq i (1- i))))
     
199.         (vlr-object-reactor (list (setq o (vlax-ename->vla-object e))) (list cl:app (cdr (assoc 5 (entget e))))
     
200.           (list
     
201.             (cons :vlr-modified 'cl:circle:callback)
     
202.           )
     
203.         )
     
204.         (vla-getxdata o cl:app 'xtyp 'xval) (setq xval (mapcar 'vlax-variant-value (vlax-safearray->list xval)))
     
205.         (vlr-object-reactor
     
206.           (mapcar
     
207.             (function
     
208.               (lambda ( h )
     
209.                 (or (entget (setq h (handent h))) (entdel h)) (vlax-ename->vla-object h)
     
210.               )
     
211.             )
     
212.             (list (caddr xval) (cadddr xval))
     
213.           )
     
214.           (list cl:app (cdr (assoc 5 (entget e)))) (list (cons :vlr-modified 'cl:line:callback))
     
215.         )
     
216.       )
     
217.     )
     
218.   )
     
219. )
     
220. 
     
221. (vl-load-com) (princ)
     
222. 
     
223. ;;------------------------------------------------------------;;
     
224. ;;                         End of File                        ;;
     
225. ;;------------------------------------------------------------;;

;;--------------=={ Associative Centerlines }==---------------;;<br /> <br /> (defun c:cl ( / _line ss e c r l1 l2 )<br />   (if<br />     (and<br />       (setq ss<br />         (ssget<br />           (list '(0 . "CIRCLE") '(-4 . "<NOT") (list -3 (list cl:app)) '(-4 . "NOT>"))<br />         )<br />       )<br />       (or (tblsearch "APPID" cl:app) (regapp cl:app))<br />     )<br />     (progn<br />       (defun _line ( p1 p2 h )<br />         (entmakex<br />           (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)<br />             (list -3<br />               (list cl:app<br />                 (cons 1002 "{") (cons 1005 h) (cons 1002 "}")<br />               )<br />             )<br />           )<br />         )<br />       )<br />       (repeat (setq i (sslength ss))<br />         (setq e  (entget (ssname ss (setq i (1- i))))<br />               h  (cdr (assoc  5 e))<br />               c  (cdr (assoc 10 e))<br />               r  (* cl:ratio (cdr (assoc 40 e)))<br />               l1 (_line (polar c 0. r) (polar c pi r) h)<br />               l2 (_line (polar c (/ pi 2.) r) (polar c (/ (* 3. pi) 2.) r) h)<br />         )<br />         (entmod<br />           (list (assoc -1 e)<br />             (list -3<br />               (list cl:app<br />                 (cons 1002 "{")<br />                 (cons 1005 (cdr (assoc 5 (entget l1))))<br />                 (cons 1005 (cdr (assoc 5 (entget l2))))<br />                 (cons 1002 "}")<br />               )<br />             )<br />           )<br />         )<br />         (vlr-object-reactor (list (vlax-ename->vla-object (cdr (assoc -1 e)))) (list cl:app h)<br />           (list<br />             (cons :vlr-modified 'cl:circle:callback)<br />           )<br />         )<br />         (vlr-object-reactor (mapcar 'vlax-ename->vla-object (list l1 l2)) (list cl:app h)<br />           (list<br />             (cons :vlr-modified 'cl:line:callback)<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br /> <br /> ;;------------------------------------------------------------;;<br /> <br /> (defun c:clremove ( / _massoc ss fl i e r d h x )<br /> <br />   (defun _massoc ( x l )<br />     (if (setq a (assoc x l))<br />       (cons (cdr a) (_massoc x (cdr (member a l))))<br />     )<br />   )<br />   <br />   (princ "\nSelect Circles to Remove Associativity <All>: ")<br />   (setq fl (list '(0 . "CIRCLE") (list -3 (list cl:app))) i -1)<br />   <br />   (if<br />     (setq ss<br />       (cond<br />         ( (ssget fl) )<br />         ( (ssget "_X" fl) )<br />       )<br />     )<br />     (while (setq e (ssname ss (setq i (1+ i)))) (setq e (entget e (list cl:app)))<br />       (foreach r (cdar (vlr-reactors :vlr-object-reactor))<br />         (if<br />           (and<br />             (setq d (vlr-data r))<br />             (listp d)<br />             (eq cl:app (car d))<br />             (or (not (cadr d)) (eq (cdr (assoc 5 e)) (cadr d)))<br />           )<br />           (vlr-remove r)<br />         )<br />       )<br />       (foreach h (_massoc 1005 (cdadr (assoc -3 e)))<br />         (if (setq x (entget (handent h)))<br />           (entmod (list (assoc -1 x) (list -3 (list cl:app))))<br />         )<br />       )<br />       (entmod (list (assoc -1 e) (list -3 (list cl:app))))<br />     )<br />   )<br />   (princ)<br /> )      <br /> <br /> ;;------------------------------------------------------------;;<br /> <br /> (defun cl:circle:callback ( owner reactor params / xtyp xval c r )<br />   (if<br />     (and<br />       (vlax-read-enabled-p owner)<br />       (progn (vla-getxdata owner cl:app 'xtyp 'xval) xval)<br />       (setq<br />         c (vlax-get owner 'center)<br />         r (* cl:ratio (vlax-get owner 'radius))<br />       )<br />     )<br />     (mapcar<br />       (function<br />         (lambda ( h a ) <br />           (if (or (entget (setq h (handent h))) (entdel h))<br />             (entmod<br />               (list (cons -1 h) (cons 10 (polar c a r)) (cons 11 (polar c (+ a pi) r)))<br />             )<br />           )<br />         )<br />       )<br />       (cddr (mapcar 'vlax-variant-value (vlax-safearray->list xval))) (list 0. (/ pi 2.))<br />     )<br />   )<br />   (princ)<br /> )<br /> <br /> ;;------------------------------------------------------------;;<br /> <br /> (defun cl:line:callback ( owner reactor params )<br />   (setq *data (list owner reactor))<br />   (vlr-command-reactor (list cl:app)<br />     (list<br />       (cons :vlr-commandended     'cl:line:modify)<br />       (cons :vlr-commandcancelled 'cl:line:cancelled)<br />       (cons :vlr-commandfailed    'cl:line:cancelled)<br />     )<br />   )<br />   (vlr-remove reactor)<br />   (princ)  <br /> )<br /> <br /> ;;------------------------------------------------------------;;<br /> <br /> (defun cl:line:modify ( reactor params / xtyp xval h ) (vlr-remove reactor)<br />   (if<br />     (and *data (not (vlax-erased-p (car *data))) (progn (vla-getxdata (car *data) cl:app 'xtyp 'xval) xval)    <br />       (or<br />         (entget<br />           (setq h<br />             (handent<br />               (caddr<br />                 (mapcar 'vlax-variant-value (vlax-safearray->list xval))<br />               )<br />             )<br />           )<br />         )<br />         (entdel h)<br />       )<br />     )<br />     (progn<br />       (cl:circle:callback (vlax-ename->vla-object h) nil nil)<br />       (vlr-add (cadr *data))<br />       (setq *data nil)<br />     )<br />   )   <br />   (princ)<br /> )<br /> <br /> ;;------------------------------------------------------------;;<br /> <br /> (defun cl:line:cancelled ( reactor params ) (vlr-remove reactor)<br />   (if *data<br />     (progn<br />       (vlr-add (cadr *data))<br />       (setq *data nil)<br />     )<br />   )<br />   (princ)<br /> )<br /> <br /> ;;------------------------------------------------------------;;<br /> <br /> (<br />   (lambda ( / r d s i e o xtyp xval )<br />     (foreach r (cdar (vlr-reactors :vlr-object-reactor))<br />       (if (and (setq d (vlr-data r)) (listp d) (eq cl:app (car d)))<br />         (vlr-remove r)<br />       )<br />     )<br />     (if (setq s (ssget "_X" (list '(0 . "CIRCLE") (list -3 (list cl:app)))))<br />       (repeat (setq i (sslength s))<br />         (setq e (ssname s (setq i (1- i))))<br />         (vlr-object-reactor (list (setq o (vlax-ename->vla-object e))) (list cl:app (cdr (assoc 5 (entget e))))<br />           (list<br />             (cons :vlr-modified 'cl:circle:callback)<br />           )<br />         )<br />         (vla-getxdata o cl:app 'xtyp 'xval) (setq xval (mapcar 'vlax-variant-value (vlax-safearray->list xval)))<br />         (vlr-object-reactor<br />           (mapcar<br />             (function<br />               (lambda ( h )<br />                 (or (entget (setq h (handent h))) (entdel h)) (vlax-ename->vla-object h)<br />               )<br />             )<br />             (list (caddr xval) (cadddr xval))<br />           )<br />           (list cl:app (cdr (assoc 5 (entget e)))) (list (cons :vlr-modified 'cl:line:callback))<br />         )<br />       )<br />     )<br />   )<br /> )<br /> <br /> (vl-load-com) (princ)<br /> <br /> ;;------------------------------------------------------------;;<br /> ;;                         End of File                        ;;<br /> ;;------------------------------------------------------------;;

香远益清

很好，前面还有一个，是分层，但不能框选，只能点选的。程序源码如下：

;;*************************;;
;;CL.lsp:     
;;Designed by pengliang  ;;
;;2005.4.21;;
;;*************************;;

(defun c:cl ()
   (setvar "cmdecho" 0)
   (setq os_old (getvar "osmode"))
   (setq cl_old (getvar "clayer"))
   (setvar "osmode" 0)
   (command "ucs" "")
;-----------------------------------------------------------------------------------------
   (if (not (tblsearch "layer" "cen"))
       (command "_.layer" "_new" "cen" "_color" "1" "cen" "_ltype" "center" "cen" "")
       (command "_.layer" "thaw" "cen" "on" "cen" "unlock" "cen" "")
   )
;------------------------------------------------------------------------------------------
  (setq a1 (entsel "\n请选定要画中心线的圆\\圆弧\\直线:"))
  (while (null a1)
       (setq a1 (entsel "\n请选定要画中心线的圆\\圆弧\\直线:"))
  )
  (setq a2 (entget (car a1)))
  (setq l1 (assoc 0 a2))
  (setq l2 (cdr l1))
  (while (and (/= l2 "LINE") (/= l2 "ARC") (/= l2 "CIRCLE"))
         (setq a1 (entsel "\n所选的不是圆\\圆弧\\直线:"))
         (while (null a1)
            (setq a1 (entsel "\n请选定要画中心线的圆\\圆弧\\直线:"))
         )
         (setq pt1 (cadr a1))
         (setq a2 (entget (car a1)))
         (setq l1 (assoc 0 a2))
         (setq l2 (cdr l1))
  )
  (if (or (= l2 "ARC") (= l2 "CIRCLE"))
      (progn
          (setq b1 (cdr (assoc 10 a2)))  ;圆心座标
          (setq b2 (cdr (assoc 40 a2)))  ;圆半径
          (setvar "clayer" "cen")
          (command "line" (list (- (car b1) (* b2 1.2)) (cadr b1)) (strcat "@" (rtos (* b2 2.4))
                          "<0") "")
          (command "array" "l" "" "p" b1 "2" "90" "")
      )
   )
  (if (or (= l2 "LINE"))
      (progn
          (setq a3 (entsel "\n请选定另一直线:"))
          (while (null a3)
                 (setq a3 (entsel "\n请选定另一直线:"))
          )
          (setq a4 (entget (car a3)))
          (setq end1 (cdr (assoc 10 a2)))
          (setq end2 (cdr (assoc 11 a2)))
          (setq end3 (cdr (assoc 10 a4)))
          (setq end4 (cdr (assoc 11 a4)))
          (setq e1 (distance end1 end3))
          (setq e2 (distance end1 end4))
          (if (< e1 e2)
             (progn
              (setq end5 (list (/ (+ (car end1) (car end3)) 2.0) (/ (+ (cadr end1) (cadr end3)) 2.0)))
              (setq end6 (list (/ (+ (car end2) (car end4)) 2.0) (/ (+ (cadr end2) (cadr end4)) 2.0)))
             )
             (progn
              (setq end5 (list (/ (+ (car end1) (car end4)) 2.0) (/ (+ (cadr end1) (cadr end4)) 2.0)))
              (setq end6 (list (/ (+ (car end2) (car end3)) 2.0) (/ (+ (cadr end2) (cadr end3)) 2.0)))
             )
          )
          (setq end5_1 (polar end5 (angle end6 end5) 10))
          (setq end6_1 (polar end6 (angle end5 end6) 10))
          (setvar "clayer" "cen")
          (command "line" end5_1 end6_1 "")
      )
   )
   (setvar "osmode" os_old)
   (setvar "clayer" cl_old)
   (princ)
)

yzh898

phoenixdjq 发表于 2006-11-19 22:09
我以前编的，但是用的是当前层的线型，因为只是自己用
你可以试一下，如果有问题的话，可以再联系

谢谢分享。

liyuwen

建议楼主不妨试试XRCAD V7.0(http://www.xrsoftware.net)中的“绘制工具”，可轻松实现圆/圆弧、直线间及圆弧间的中心线绘制功能。

whb122

intecad功能强大，什么都有。

qyr_0_0

好的，谢谢各位！

phoenixdjq

我以前编的，但是用的是当前层的线型，因为只是自己用

你可以试一下，如果有问题的话，可以再联系

鬼魔

5楼写的程序不错,好用要顶下

yzh898

谢谢分享。