文字对齐

自贡黄明儒 发表于 2012-2-25 14:16:48

本帖最后由自贡黄明儒于 2013-3-23 12:08 编辑

;;;关于对齐，明经中有不少的好程序了，但多半操作复杂。用得最多的恐怕是文字对齐。我原来用Align的程序，
;;;是编译过的.但这个程序什么对象都用来对齐，不能满足我的需要。于是.....

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;自贡黄明儒
(defun C:ao (/ CMDECHO1 KEY SSET SSETCIRCLE SSETELSE SSETINSERT SSETMTEXT SSETTEXT SSETATTDEF)
;;1选择集相减
(defun SS_SSsub (ss1 ss2 / ss)
(command "._Select" ss1 "_Remove" ss2 "")
(if (equal (sslength ss1) (sslength ss2))
   nil
   (setq ss (ssget "_P"))
)
)
;;2获取对象的外边框
(defun HH:MinMaxPt (ent / MinPt MaxPt)
;;(vl-load-com)
(vla-GetBoundingBox (vlax-Ename->vla-Object ent) 'MinPt 'MaxPt)
(mapcar 'vlax-safearray->list (list MinPt MaxPt))
)
;;3.1text选择集在x方向距离<文字宽度,认为在同一列
;; 左中中中对齐方式有效
(defun HH:TextInSameColu (ss / E1 E2 LIS1 LIS2 N P1 P2 SS1 WID1 WID2)
(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 11 (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 11 (entget e2))))
   (if (< (abs (- (car p1) (car p2))) (max wid1 wid2))
   (progn (setq SS1 (ssadd e2 ss1)) (vl-cmdf "_.MOVE" e2 "" p2 ".X" p1 "@"))
   )
)
ss1
)
;;3.2Mtext选择集在x方向距离<文字宽度,认为在同一列
;; 左中中中对齐方式有效
(defun HH:MTextInSameColu (ss / E1 E2 LIS1 LIS2 N P1 P2 SS1 WID1 WID2)
(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 10 (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 10 (entget e2))))
   (if (< (abs (- (car p1) (car p2))) (max wid1 wid2))
   (progn (setq SS1 (ssadd e2 ss1)) (vl-cmdf "_.MOVE" e2 "" p2 ".X" p1 "@"))
   )
)
ss1
)
;;4.1 text在Y方向距离,圆整成字高2倍
;; 左中中中对齐方式有效
(defun HH:TextInSameRow (ss / E1 E2 H HIG1 LIS1 N P1 P2 P2T)
(setq e1 (ssname ss 0))
(setq lis1 (HH:MinMaxPt e1))
(setq hig1 (* 2.0 (- (cadr (cadr lis1)) (cadr (car lis1)))))
(setq p1 (cdr (assoc 11 (entget e1))))
(setq n 0)
(repeat (1- (sslength ss))
   (setq e2 (ssname ss (setq n (1+ n))))
   (setq p2 (cdr (assoc 11 (entget e2))))
   (setq H (- (cadr p2) (cadr p1)))
   (if (> H 0)
   (setq H (fix (+ (/ H hig1) 0.5)))
   (setq H (fix (- (/ H hig1) 0.5)))
   )
   (setq p2t (list (car p1) (+ (* H hig1) (cadr p1)) 0.0))
   (vl-cmdf "_.MOVE" e2 "" p2 ".Y" p2t "@")
)
)
;;4.2 Mtext在Y方向距离,圆整成字高2倍
;; 左中中中对齐方式有效
(defun HH:MTextInSameRow (ss / E1 E2 H HIG1 LIS1 N P1 P2 P2T)
(setq e1 (ssname ss 0))
(setq lis1 (HH:MinMaxPt e1))
(setq hig1 (* 2.0 (- (cadr (cadr lis1)) (cadr (car lis1)))))
(setq p1 (cdr (assoc 10 (entget e1))))
(setq n 0)
(repeat (1- (sslength ss))
   (setq e2 (ssname ss (setq n (1+ n))))
   (setq p2 (cdr (assoc 10 (entget e2))))
   (setq H (* (- (cadr p2) (cadr p1)) 2.0))
   (if (> H 0)
   (setq H (fix (+ (/ H hig1) 0.5)))
   (setq H (fix (- (/ H hig1) 0.5)))
   )
   (setq p2t (list (car p1) (+ (* H hig1) (cadr p1)) 0.0))
   (vl-cmdf "_.MOVE" e2 "" p2 ".Y" p2t "@")
)
)
;;5.1Text选择集中找出相同列,返回其余
(defun Textsamecolum (sSet / SS SS1)
(setq ss1 (HH:TextInSameColu sSet))
(if (setq ss (SS_SSsub sSet ss1))
   (Textsamecolum ss)
)
)
;;5.2MText选择集中找出相同列,返回其余
(defun MTextsamecolum (sSet / SS SS1)
(setq ss1 (HH:MTextInSameColu sSet))
(if (setq ss (SS_SSsub sSet ss1))
   (MTextsamecolum ss)
)
)
;;6主程序
(if (cadr (ssgetfirst))
(setq sSet (ssget "_P" '((0 . "*TEXT"))))
)
(if sSet
nil
(setq sSet (ssget))
)
(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"))))
(cond (sSetText
      (initget "mC mL");区分大小写
      (setq key (getkword "\n文本对齐于 [正中(C)/左中(L)]:<C>"))
      (if (not key)
      (setq key "MC")
      )
      (setq key (strcase key))
      (command "_.JUSTIFYTEXT" sSetText "" key)
      (HH:TextInSameRow sSetText)
      (Textsamecolum sSetText)
   )
   (sSetMText
      (initget "mC mL")
      (setq key (getkword "\n文本对齐于 [正中(C)/左中(L)]:<C>"))
      (if (not key)
      (setq key "MC")
      )
      (setq key (strcase key))
      (command "_.JUSTIFYTEXT" sSetMText "" key)
      (HH:MTextInSameRow sSetMText)
      (MTextsamecolum sSetMText)
   )
   (sSetATTDEF
      (initget "mC mL")
      (setq key (getkword "\n文本对齐于 [正中(C)/左中(L)]:<C>"))
      (if (not key)
      (setq key "MC")
      )
      (setq key (strcase key))
      (command "_.JUSTIFYTEXT" sSetATTDEF "" key)
      (HH:TextInSameRow sSetATTDEF)
      (Textsamecolum sSetATTDEF)
   )
   (sSetCIRCLE (HH:MTextInSameRow sSetCIRCLE) (MTextsamecolum sSetCIRCLE))
   (sSetINSERT (HH:MTextInSameRow sSetINSERT) (MTextsamecolum sSetINSERT))
   (T (princ "\n 只能处理文字、圆(椭圆)、块"))
)
(setvar "cmdecho" cmdecho1)
(command "undo" "END")
(princ)
)
(princ "\n命令:AO")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

自贡黄明儒 发表于 2012-2-25 14:20:16

默认行间距为：第一个对象高度的2倍

puzb2001 发表于 2012-2-25 14:33:27

大师作品，纯顶！

vlisp2012 发表于 2012-2-25 16:01:55

很好的程序。学习了。

自贡黄明儒 发表于 2012-3-13 11:34:00

原来的不能文字避让，自己希望改后的更好

wjl1014 发表于 2013-3-23 11:30:25

程序不错，就是要收费。

42112522 发表于 2013-6-23 19:37:15

默认行间距为：第一个对象高度的2倍

非你可1 发表于 2014-3-3 19:38:58

非常哇塞啊

上善如水 发表于 2014-4-16 20:28:00

如果能加个排序就更好了

消失的天空 发表于 2019-5-2 10:52:08

先收藏了。不知道效果怎么样，我一直在找表格内文字对齐，能横竖同时运行的。

页: [1]

明经CAD社区's Archiver

文字对齐