急寻一个画中心线的好方法或程序
急寻一个画中心线的好方法或程序！谢过！ ;;--------------=={ Associative Centerlines }==---------------;;(defun c:cl ( / _line ss e c r l1 l2 )
(if
(and
(setq ss
(ssget
(list '(0 . "CIRCLE") '(-4 . "<NOT") (list -3 (list cl:app)) '(-4 . "NOT>"))
)
)
(or (tblsearch "APPID" cl:app) (regapp cl:app))
)
(progn
(defun _line ( p1 p2 h )
(entmakex
(list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)
(list -3
(list cl:app
(cons 1002 "{") (cons 1005 h) (cons 1002 "}")
)
)
)
)
)
(repeat (setq i (sslength ss))
(setq e(entget (ssname ss (setq i (1- i))))
h(cdr (assoc5 e))
c(cdr (assoc 10 e))
r(* cl:ratio (cdr (assoc 40 e)))
l1 (_line (polar c 0. r) (polar c pi r) h)
l2 (_line (polar c (/ pi 2.) r) (polar c (/ (* 3. pi) 2.) r) h)
)
(entmod
(list (assoc -1 e)
(list -3
(list cl:app
(cons 1002 "{")
(cons 1005 (cdr (assoc 5 (entget l1))))
(cons 1005 (cdr (assoc 5 (entget l2))))
(cons 1002 "}")
)
)
)
)
(vlr-object-reactor (list (vlax-ename->vla-object (cdr (assoc -1 e)))) (list cl:app h)
(list
(cons :vlr-modified 'cl:circle:callback)
)
)
(vlr-object-reactor (mapcar 'vlax-ename->vla-object (list l1 l2)) (list cl:app h)
(list
(cons :vlr-modified 'cl:line:callback)
)
)
)
)
)
(princ)
)
;;------------------------------------------------------------;;
(defun c:clremove ( / _massoc ss fl i e r d h x )
(defun _massoc ( x l )
(if (setq a (assoc x l))
(cons (cdr a) (_massoc x (cdr (member a l))))
)
)
(princ "\nSelect Circles to Remove Associativity <All>: ")
(setq fl (list '(0 . "CIRCLE") (list -3 (list cl:app))) i -1)
(if
(setq ss
(cond
( (ssget fl) )
( (ssget "_X" fl) )
)
)
(while (setq e (ssname ss (setq i (1+ i)))) (setq e (entget e (list cl:app)))
(foreach r (cdar (vlr-reactors :vlr-object-reactor))
(if
(and
(setq d (vlr-data r))
(listp d)
(eq cl:app (car d))
(or (not (cadr d)) (eq (cdr (assoc 5 e)) (cadr d)))
)
(vlr-remove r)
)
)
(foreach h (_massoc 1005 (cdadr (assoc -3 e)))
(if (setq x (entget (handent h)))
(entmod (list (assoc -1 x) (list -3 (list cl:app))))
)
)
(entmod (list (assoc -1 e) (list -3 (list cl:app))))
)
)
(princ)
)
;;------------------------------------------------------------;;
(defun cl:circle:callback ( owner reactor params / xtyp xval c r )
(if
(and
(vlax-read-enabled-p owner)
(progn (vla-getxdata owner cl:app 'xtyp 'xval) xval)
(setq
c (vlax-get owner 'center)
r (* cl:ratio (vlax-get owner 'radius))
)
)
(mapcar
(function
(lambda ( h a )
(if (or (entget (setq h (handent h))) (entdel h))
(entmod
(list (cons -1 h) (cons 10 (polar c a r)) (cons 11 (polar c (+ a pi) r)))
)
)
)
)
(cddr (mapcar 'vlax-variant-value (vlax-safearray->list xval))) (list 0. (/ pi 2.))
)
)
(princ)
)
;;------------------------------------------------------------;;
(defun cl:line:callback ( owner reactor params )
(setq *data (list owner reactor))
(vlr-command-reactor (list cl:app)
(list
(cons :vlr-commandended 'cl:line:modify)
(cons :vlr-commandcancelled 'cl:line:cancelled)
(cons :vlr-commandfailed 'cl:line:cancelled)
)
)
(vlr-remove reactor)
(princ)
)
;;------------------------------------------------------------;;
(defun cl:line:modify ( reactor params / xtyp xval h ) (vlr-remove reactor)
(if
(and *data (not (vlax-erased-p (car *data))) (progn (vla-getxdata (car *data) cl:app 'xtyp 'xval) xval)
(or
(entget
(setq h
(handent
(caddr
(mapcar 'vlax-variant-value (vlax-safearray->list xval))
)
)
)
)
(entdel h)
)
)
(progn
(cl:circle:callback (vlax-ename->vla-object h) nil nil)
(vlr-add (cadr *data))
(setq *data nil)
)
)
(princ)
)
;;------------------------------------------------------------;;
(defun cl:line:cancelled ( reactor params ) (vlr-remove reactor)
(if *data
(progn
(vlr-add (cadr *data))
(setq *data nil)
)
)
(princ)
)
;;------------------------------------------------------------;;
(
(lambda ( / r d s i e o xtyp xval )
(foreach r (cdar (vlr-reactors :vlr-object-reactor))
(if (and (setq d (vlr-data r)) (listp d) (eq cl:app (car d)))
(vlr-remove r)
)
)
(if (setq s (ssget "_X" (list '(0 . "CIRCLE") (list -3 (list cl:app)))))
(repeat (setq i (sslength s))
(setq e (ssname s (setq i (1- i))))
(vlr-object-reactor (list (setq o (vlax-ename->vla-object e))) (list cl:app (cdr (assoc 5 (entget e))))
(list
(cons :vlr-modified 'cl:circle:callback)
)
)
(vla-getxdata o cl:app 'xtyp 'xval) (setq xval (mapcar 'vlax-variant-value (vlax-safearray->list xval)))
(vlr-object-reactor
(mapcar
(function
(lambda ( h )
(or (entget (setq h (handent h))) (entdel h)) (vlax-ename->vla-object h)
)
)
(list (caddr xval) (cadddr xval))
)
(list cl:app (cdr (assoc 5 (entget e)))) (list (cons :vlr-modified 'cl:line:callback))
)
)
)
)
)
(vl-load-com) (princ)
;;------------------------------------------------------------;;
;; End of File ;;
;;------------------------------------------------------------;; 很好，前面还有一个，是分层，但不能框选，只能点选的。程序源码如下：
;;*************************;;
;;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)
)
phoenixdjq 发表于 2006-11-19 22:09
我以前编的，但是用的是当前层的线型，因为只是自己用
你可以试一下，如果有问题的话，可以再联系
谢谢分享。 建议楼主不妨试试XRCAD V7.0(<A href="http://www.xrsoftware.net/" target="_blank" >http://www.xrsoftware.net</A>)中的“绘制工具”，可轻松实现圆/圆弧、直线间及圆弧间的中心线绘制功能。 intecad功能强大，什么都有。 <P>好的，谢谢各位！</P> <P>我以前编的，但是用的是当前层的线型，因为只是自己用</P>
<P>你可以试一下，如果有问题的话，可以再联系</P> 5楼写的程序不错,好用要顶下 谢谢分享。
页:
[1]
2