批量文字中心对齐圆芯的程序

smartstar · 发表于 2012-9-11 08:18:34

本帖最后由 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)
)

;;; -----------------------------------------------------------------;    
(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) 
)

hdlyt11 · 发表于 2012-9-11 09:14:26

能否改完文字插入点与型心对齐呢？

ps122hb · 发表于 2012-9-11 12:45:31

这个东西不复杂，开放一下源码吧

阳光动力 · 发表于 2012-9-11 14:25:27

本帖最后由阳光动力于 2012-9-11 14:25 编辑

无论如何也要支持下

hn_zhwang · 发表于 2012-12-4 14:27:18

要每个实体过一遍看哪个离点最近

ljttjl · 发表于 2012-12-4 21:39:23

zdqwy19 · 发表于 2012-12-5 00:35:51

光是圆倒简单，关键移到圆心并正中对正有什么作用。我也经常把别人的图纸这样改过，不过对正方式改为左对齐，我是为了使用Cad自带的数据提取功能。

love12314 · 发表于 2012-12-5 21:42:14

关注中

softschool · 发表于 2013-6-27 01:02:16

感谢分享实用的工具

清风明月名字 · 发表于 2013-6-27 07:33:48

程序用途: 批量文字对齐相邻圆

使用说明:

本程序使用VC++编写,支持在AutoCAD2010~2012版本上运行,请直接在CAD中加载ScmTxApCir.arx文件即可用.

CAD命令: tac

我的是2005，没有用

账号		自动登录	找回密码
密码			注册

批量文字中心对齐圆芯的程序

点评

本帖子中包含更多资源