本帖最后由 smartstar 于 2012-9-11 08:23 编辑
试试这个符合你的要求不
;;; -----------------------------------------------------------------;
(defun c:ARK_TTC (/ std-sslist movetocenter)
(command "_undo" "_be")
(setting)
(defun std-sslist (ss / n lst)
(if (eq 'pickset (type ss))
(repeat (setq n (fix (sslength ss))) ; fixed
(setq lst (cons (ssname ss (setq n (1- n))) lst))
)
)
)
(defun movetocenter (/ a x txtobj
center_circle outline b
bobject objss res midpoint
)
(setq a (ssget '((0 . "circle"))))
(setq a (std-sslist a))
(foreach x a
(setq txtobj nil)
(setq pub x)
(setq center_circle (assoc 10 (entget x)))
(setq outline (objectpoint (entget x)))
(setq b (ssget "_cp" outline '((0 . "TEXT"))))
(setq bobject (ssname b 0))
(setq objss (vlax-ename->vla-object bobject))
(setq res (xyval1 objss))
(setq midpoint (midp (list (nth 0 res) (nth 1 res))
(list
(nth 2 res)
(nth 3 res)
)
)
)
(setq midpoint (trans midpoint 0 1)
c_pt (trans (cdr center_circle) 0 1)
)
(command "move" bobject "" midpoint c_pt)
)
)
(movetocenter)
(resetting)
(command "_undo" "_e")
)
;;; the subrountine is write by qjchen to get selection by circle
;;; and lwpolyline
(defun objectpoint (obj / name ori i r w_pl_lst wlist)
(setq wlist nil
ptlist nil
)
(setq name (cdr (assoc 0 obj)))
(cond
((= name "CIRCLE")
(setq ori (cdr (assoc 10 obj)))
(setq r (cdr (assoc 40 obj)))
(setq i 0)
(repeat 30
(setq wlist (append
wlist
(list (polar ori (* 2 pi (/ i 30.0)) r))
)
)
(setq i (1+ i))
)
)
((= name "LWPOLYLINE")
(defun w_pl_lst (ent / pt_list)
(foreach x ent
(if (= (car x) 10)
(setq pt_list (append
(list (cdr x))
pt_list
)
)
)
)
pt_list
)
(setq wlist (w_pl_lst obj))
)
)
(setq num (length wlist))
(setq n 0)
(repeat num
(setq pt (list (trans (nth n wlist) 0 1)))
(setq ptlist (append ptlist pt))
(setq n (1+ n))
)
ptlist
)
;;; _ end of xyval
;;; ---The following codes are copy From Tony Hotchkiss at cadalyst
;;; Get the boundingbox of one object
(defun xyval1 (obj / minpt maxpt topy bottmy leftx rightx)
(vla-GetBoundingBox obj 'minpt 'maxpt)
(setq pt1 (vlax-safearray->list minpt)
pt2 (vlax-safearray->list maxpt)
topy (cadr pt2)
bottmy (cadr pt1)
leftx(car pt1)
rightx (car pt2)
) ; _ end of setq
(list leftx bottmy rightx topy)
)
;;; The error function
(defun err (s)
(if (= s "Function cancelled")
(princ "nALIGNIT - cancelled: ")
(progn
(princ "nALIGNIT - Error: ")
(princ s)
(terpri)
) ; _ end of progn
) ; _ end of if
(resetting)
(princ "SYSTEM VARIABLES have been resetn")
(princ)
)
;;; err
;;; setting and resetting the system variables
(defun setv (systvar newval / x)
(setq x (read (strcat systvar "1")))
(set x (getvar systvar))
(setvar systvar newval)
)
;;; setv
(defun setting ()
(setq oerr *error*)
(setq *error* err)
(setv "BLIPMODE" 0)
(setv "CMDECHO" 0)
(setv "OSMODE" 0)
)
;;; setting
(defun rsetv (systvar)
(setq x (read (strcat systvar "1")))
(setvar systvar (eval x))
)
;;; rsetv
(defun resetting ()
(rsetv "BLIPMODE")
(rsetv "CMDECHO")
(rsetv "OSMODE")
(setq *error* oerr)
)
;;; -------------------------------------------------------
(defun midp (p1 p2)
(mapcar
'(lambda (x)
(/ x 2.)
)
(mapcar
'+
p1
p2
)
)
)
;;; The following code taken From Mr.Tony Hotchkiss at Cadalyst
(defun err (s)
(if (= s "Function cancelled")
(princ "nregion clean - cancelled: ")
(progn
(princ "nregion clean - Error: ")
(princ s)
(terpri)
) ; _ end of progn
) ; _ end of if
(resetting)
(princ "SYSTEM VARIABLES have been resetn")
(princ)
)
;;; err
;;; setting and resetting the system variables
(defun setv (systvar newval / x)
(setq x (read (strcat systvar "1")))
(set x (getvar systvar))
(setvar systvar newval)
)
;;; setv
(defun setting ()
(setq oerr *error*)
(setq *error* err)
(setv "BLIPMODE" 0)
(setv "CMDECHO" 0)
(setv "OSMODE" 0)
)
;;; setting
(defun rsetv (systvar)
(setq x (read (strcat systvar "1")))
(setvar systvar (eval x))
)
;;; rsetv
(defun resetting ()
(rsetv "BLIPMODE")
(rsetv "CMDECHO")
(rsetv "OSMODE")
(setq *error* oerr)
)
能否改完文字插入点与型心对齐呢？
这个东西不复杂，开放一下源码吧
本帖最后由 阳光动力 于 2012-9-11 14:25 编辑
无论如何也要支持下
要每个实体过一遍看哪个离点最近
光是圆倒简单，关键移到圆心并正中对正有什么作用。我也经常把别人的图纸这样改过，不过对正方式改为左对齐，我是为了使用Cad自带的数据提取功能。
关注中
感谢分享实用的工具
程序用途: 批量文字对齐相邻圆
使用说明:
本程序使用VC++编写,支持在AutoCAD2010~2012版本上运行,请直接在CAD中加载ScmTxApCir.arx文件即可用.
CAD命令: tac
我的是2005，没有用