对象对齐---天公劝我重抖擞,字不对齐誓不休

自贡黄明儒 · 发表于 2012-3-14 09:19

本帖最后由自贡黄明儒于 2012-8-23 10:21 编辑

我见95%以上的AutoCAD绘图人员(哎,见识太少),字体总是对不齐(嘿嘿,我也是其中之一,说来惭愧!),这要怪Autocad,谁让它不提供对象对齐工具呢(借口还可以吧)?
热心网友提供的文字对齐工具,有些是操作复杂,有些运行慢......总之不符合我的要求。原来写了一个，不能进行文字避让，今有所改善，希望能完美。
运行结果证明，还是有瑕疵，伸出你高贵的手，为了我们共同的目标，完善它，推广它。在此我给菩萨心肠的你鞠躬了。一鞠躬，二鞠躬，三鞠躬......

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun C:ao (/ CMDECHO1 E1 HIG1 HIG2 KEY LIS1
SS SSET SSETATTDEF SSETCIRCLE SSETINSERT SSETMTEXT SSETTEXT
)
;;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 H I LIS1
LIS2 LISTMINUS LISTPLUS N P1 P2 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)
)
)
;;6 Y间距<行间距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)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun C:ao (/  CMDECHO1   E1       HIG1  HIG2     KEY        LIS1 
      SS  SSET    SSETATTDEF SSETCIRCLE SSETINSERT SSETMTEXT  SSETTEXT 
     ) 
  ;;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   H  I LIS1 
   LIS2   LISTMINUS     LISTPLUS    N   P1  P2 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) 
    ) 
  ) 
  ;;6  Y间距<行间距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

ninja37 · 发表于 2020-11-1 18:58

自贡黄明儒你好我想问一下附件的大小是0byte 下载下来是不能用的损坏的文件

cocoorange · 发表于 2019-6-19 10:45

很不错的工具，不过还可以再改进一下，谢谢分享

hellowuan · 发表于 2020-3-19 23:00

这个功能真的好强大！

xiaxiang · 发表于 2012-3-14 11:14

赞一个，附件跟贴出来的程序是不是一个东西？

自贡黄明儒 · 发表于 2012-3-14 11:26

本帖最后由自贡黄明儒于 2012-3-14 11:29 编辑

xiaxiang 发表于 2012-3-14 11:14
赞一个，附件跟贴出来的程序是不是一个东西？

是一个东西，只差一个函数Sort_X_pList。其实没有这个函数，你也可以猜出来

xiaxiang · 发表于 2012-3-14 11:44

原来是少一个点表排序函数！程序功能不错，感谢分享！

革天明 · 发表于 2012-3-14 11:56

谢谢楼主分享

669423907 · 发表于 2012-3-14 12:00

谢谢楼主分享，楼主精神可嘉！

puzb2001 · 发表于 2012-3-14 14:40

谢谢楼主分享

soly2006 · 发表于 2012-3-14 15:01

xx ,如果再配上个动画，此帖必更火

langjs · 发表于 2012-3-14 18:13

不错支持一下下

江湖远人 · 发表于 2012-3-14 21:21

多谢楼主分享，学习了

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

对象对齐---天公劝我重抖擞,字不对齐誓不休

本帖子中包含更多资源

点评

评分

点评

浏览过的版块