对象对齐---天公劝我重抖擞,字不对齐誓不休
本帖最后由 自贡黄明儒 于 2012-8-23 10:21 编辑我见95%以上的AutoCad绘图人员(哎,见识太少),字体总是对不齐(嘿嘿,我也是其中之一,说来惭愧!),这要怪Autocad,谁让它不提供对象对齐工具呢(借口还可以吧)?
热心网友提供的文字对齐工具,有些是操作复杂,有些运行慢......总之不符合我的要求。原来写了一个，不能进行文字避让，今有所改善，希望能完美。
运行结果证明，还是有瑕疵，伸出你高贵的手，为了我们共同的目标，完善它，推广它。在此我给菩萨心肠的你鞠躬了。一鞠躬，二鞠躬，三鞠躬......
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun C:ao (/CMDECHO1 E1 HIG1HIG2 KEY LIS1
SSSSET SSETATTDEF SSETCIRCLE SSETINSERT SSETMTEXTSSETTEXT
)
;;2点表排序
(defun Sort_X_pList (PLIST / p1 p2)
(setq plist (vl-sort plist
'(lambda (p1 p2)
(cond ((< (car p1) (car p2)) T)
(T nil)
)
)
)
)
)
;;3选择集相减
(defun SS_SSsub (ss1 ss2 / ss)
(command "._Select" ss1 "_Remove" ss2 "")
(if (equal (sslength ss1) (sslength ss2))
nil
(setq ss (ssget "_P"))
)
)
;;4获取对象的外边框
(defun HH:MinMaxPt (ent / MinPt MaxPt)
(vla-GetBoundingBox
(vlax-Ename->vla-Object ent)
'MinPt
'MaxPt
)
(mapcar 'vlax-safearray->list (list MinPt MaxPt))
)
;;5处理列******************************************************
;; 左中 中中对齐方式有效
;;Mtext code=10,其余code=11
(defun TextInSameCol (ss code hig1 / E1 E2 HI LIS1
LIS2 LISTMINUS LISTPLUS N P1P2 elist
SS1 WID WID1 WID2 Y
)
(setq e1 (ssname ss 0))
(setq SS1 (ssadd e1 (ssadd)))
(setq lis1 (HH:MinMaxPt e1))
(setq wid1 (- (car (cadr lis1)) (car (car lis1))))
(setq p1 (cdr (assoc code (entget e1))))
(setq n 0)
(repeat (1- (sslength ss))
(setq e2 (ssname ss (setq n (1+ n))))
(setq lis2 (HH:MinMaxPt e2))
(setq wid2 (- (car (cadr lis2)) (car (car lis2))))
(setq p2 (cdr (assoc code (entget e2))))
(setq H (- (cadr p2) (cadr p1)))
(setq wid (< (abs (- (car p1) (car p2))) (/ (+ wid1 wid2) 2.0)))
(if wid
(progn
(setq SS1 (ssadd e2 ss1))
(if (> H 0)
(setq ListPlus (cons (list H e2) ListPlus))
(setq ListMinus (cons (list H e2) ListMinus))
)
)
)
)
(setq ListPlus (Sort_X_pList ListPlus))
(setq ListMinus (reverse (Sort_X_pList ListMinus)))
(setq i 0)
(setq n (length ListPlus))
(if ListPlus
(repeat n
(setq i (1+ i))
(setq e2 (cadr (car ListPlus)))
(setq ListPlus (cdr ListPlus))
(setq p2 (cdr (assoc code (entget e2))))
(setq y (- (cadr p2) (cadr p1)))
(if (> (setq y (fix (+ (/ y hig1) 0.5))) i)
(setq i y)
)
(setq elist (entget e2))
(setq p2 (list (car p1) (+ (cadr p1) (* i hig1)) 0.0))
(entmod (subst (cons code p2) (assoc code elist) elist))
)
)
(setq i 0)
(setq n (length ListMinus))
(if ListMinus
(repeat n
(setq i (1+ i))
(setq e2 (cadr (car ListMinus)))
(setq ListMinus (cdr ListMinus))
(setq p2 (cdr (assoc code (entget e2))))
(setq y (- (cadr p1) (cadr p2)))
(if (> (setq y (fix (+ (/ y hig1) 0.5))) i)
(setq i y)
)
(setq elist (entget e2))
(setq p2 (list (car p1) (- (cadr p1) (* i hig1)) 0.0))
(entmod (subst (cons code p2) (assoc code elist) elist))
)
)
(setq ss (SS_SSsub ss ss1))
(if ss
(TextInSameCol ss code hig1)
)
)
;;6Y间距<行间距hig1,认为在同一行,则使其在x向对齐**********************
;; 左中 中中对齐方式有效
;;Mtext code=10,其余code=11
;;(setq ss (ssget) code 11 hig1 7)
(defun TextInSameRow (ss code hig1 / E1 E2 H N P1 P2 SS1 elist)
(setq e1 (ssname ss 0))
(setq SS1 (ssadd e1 (ssadd)))
(setq p1 (cdr (assoc code (entget e1))))
(setq n 0)
(repeat (1- (sslength ss))
(setq e2 (ssname ss (setq n (1+ n))))
(setq p2 (cdr (assoc code (entget e2))))
(setq H (abs (- (cadr p1) (cadr p2))))
(if (< (abs H) hig1)
(progn (setq SS1 (ssadd e2 ss1))
(setq elist (entget e2))
(setq p2 (list (car p2) (cadr p1) 0.0))
(entmod (subst (cons code p2) (assoc code elist) elist)) ;在Y向移动
)
)
)
(setq ss (SS_SSsub ss ss1))
(if ss
(TextInSameRow ss code hig1)
)
)
;;7主程序
(if (cadr (ssgetfirst))
(setq
sSet (ssget "_P"
'((0 . "*TEXT,ATTDEF,CIRCLE,ARC,ELLIPSE,INSERT"))
)
)
)
(princ "\n 单行文字、多行文字、块、圆依次择其一类对齐")
(if sSet
nil
(setq
sSet (ssget '((0 . "*TEXT,ATTDEF,CIRCLE,ARC,ELLIPSE,INSERT")))
)
)
(vl-load-com)
(command "undo" "be")
(setq cmdecho1 (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "._Select" sSet "")
(setq sSetText (ssget "_p" '((0 . "TEXT"))))
(command "._Select" sSet "")
(setq sSetMText (ssget "_p" '((0 . "MTEXT"))))
(command "._Select" sSet "")
(setq sSetATTDEF (ssget "_p" '((0 . "ATTDEF"))))
(command "._Select" sSet "")
(setq sSetCIRCLE (ssget "_p" '((0 . "CIRCLE,ARC,ELLIPSE"))))
(command "._Select" sSet "")
(setq sSetINSERT (ssget "_p" '((0 . "INSERT"))))
(if (or sSetText sSetMText sSetATTDEF)
(progn (initget "mC mL") ;区分大小写
(setq key (getkword "\n文本对齐于 [正中(C)/左中(L)]:<C>"))
(if (not key)
(setq key "MC")
)
(setq key (strcase key))
(command "_.JUSTIFYTEXT" sSetText "" key)
)
)
(cond (sSetText (setq ss sSetText))
(sSetMText (setq ss sSetMText))
(sSetATTDEF (setq ss sSetATTDEF))
(sSetINSERT (setq ss sSetINSERT))
(sSetCIRCLE (setq ss sSetCIRCLE))
)
(setq e1 (ssname ss 0))
(setq lis1 (HH:MinMaxPt e1))
(initget 46)
(setq hig2 (* 2.0 (- (cadr (cadr lis1)) (cadr (car lis1)))))
(setq
hig1 (getreal (strcat "\n >>输入行间距<" (rtos hig2 2 3) ">:"))
)
(if hig1
nil
(setq hig1 hig2)
)
(cond (sSetText
(TextInSameRow sSetText 11 hig1)
(TextInSameCol sSetText 11 hig1)
)
(sSetMText
(TextInSameRow sSetMText 10 hig1)
(TextInSameCol sSetMText 10 hig1)
)
(sSetATTDEF
(TextInSameRow sSetATTDEF 11 hig1)
(TextInSameCol sSetATTDEF 11 hig1)
)
(sSetINSERT
(TextInSameRow sSetINSERT 10 hig1)
(TextInSameCol sSetINSERT 10 hig1)
)
(sSetCIRCLE
(TextInSameRow sSetCIRCLE 10 hig1)
(TextInSameCol sSetCIRCLE 10 hig1)
)
)
(setvar "cmdecho" cmdecho1)
(command "undo" "END")
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
mccad给予好评了，怎么也得将代码优化一下,见压缩文件
优化方法http://bbs.mjtd.com/thread-93264-1-1.html
自贡黄明儒 你好我想问一下附件的大小是0byte下载下来是不能用的损坏的文件 很不错的工具，不过还可以再改进一下，谢谢分享 这个功能真的好强大！ 赞一个，附件跟贴出来的程序是不是一个东西？ 本帖最后由 自贡黄明儒 于 2012-3-14 11:29 编辑
xiaxiang 发表于 2012-3-14 11:14 http://bbs.mjtd.com/static/image/common/back.gif
赞一个，附件跟贴出来的程序是不是一个东西？
是一个东西，只差一个函数Sort_X_pList。其实没有这个函数，你也可以猜出来 原来是少一个点表排序函数！程序功能不错，感谢分享！ 谢谢楼主分享 谢谢楼主分享，楼主精神可嘉！ 谢谢楼主分享 xx ,如果再配上个动画，此帖必更火 不错支持一下下 多谢楼主分享，学习了