散开的单个文字合并成单行的文字实体

Lisphk · 发表于 2017-5-24 08:45:16

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;;----------------------=={ Merge Text }==--------------------;;
;; ;;
;; Converts a selection of single-character text objects ;;
;; into one or more text objects containing characters ;;
;; aligned by their insertion points & angle of rotation. ;;
;; Currently restricted to text containing no spaces. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
(defun c:mergetext ( / i l s )
(if (setq s (ssget "_:L" '((0 . "TEXT"))))
(progn
(repeat (setq i (sslength s))
(setq l (cons (entget (ssname s (setq i (1- i)))) l))
)
(foreach g
(LM:GroupByFunction l
(lambda ( a b / n r z )
(and
(equal (setq r (cdr (assoc 050 a))) (cdr (assoc 050 b)) 0.001)
(equal (setq z (cdr (assoc 210 a))) (cdr (assoc 210 b)) 0.001)
(setq n (list (cos r) (sin r)))
(equal
(car (trans (cdr (assoc 10 a)) z n))
(car (trans (cdr (assoc 10 b)) z n))
0.001
)
)
)
)
(if (cdr g)
(progn
(setq g
(vl-sort g
(function
(lambda ( a b / n r z )
(setq r (cdr (assoc 050 a))
z (cdr (assoc 210 a))
n (list (cos r) (sin r))
)
(< (last (trans (cdr (assoc 10 a)) z n))
(last (trans (cdr (assoc 10 b)) z n))
)
)
)
)
)
(entmod
(subst
(cons 1 (apply 'strcat (mapcar '(lambda ( x ) (cdr (assoc 1 x))) g)))
(assoc 1 (car g))
(car g)
)
)
(foreach e (cdr g) (entdel (cdr (assoc -1 e))))
)
)
)
)
)
(princ)
)
;; Group By Function - Lee Mac
;; Groups items considered equal by a given predicate function
(defun LM:GroupByFunction ( lst fun / tmp1 tmp2 x1 )
(if (setq x1 (car lst))
(progn
(foreach x2 (cdr lst)
(if (fun x1 x2)
(setq tmp1 (cons x2 tmp1))
(setq tmp2 (cons x2 tmp2))
)
)
(cons (cons x1 (reverse tmp1)) (LM:GroupByFunction (reverse tmp2) fun))
)
)
)
(princ)

;;----------------------=={ Merge Text }==--------------------;; 
;;                                                            ;; 
;;  Converts a selection of single-character text objects     ;; 
;;  into one or more text objects containing characters       ;; 
;;  aligned by their insertion points & angle of rotation.    ;; 
;;  Currently restricted to text containing no spaces.        ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright &#169; 2012 - <a href=\"http://www.lee-mac.com\" target=\"_blank\">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
 
(defun c:mergetext ( / i l s ) 
    (if (setq s (ssget "_:L" '((0 . "TEXT")))) 
        (progn 
            (repeat (setq i (sslength s)) 
                (setq l (cons (entget (ssname s (setq i (1- i)))) l)) 
            ) 
            (foreach g 
                (LM:GroupByFunction l 
                    (lambda ( a b / n r z ) 
                        (and 
                            (equal (setq r (cdr (assoc 050 a))) (cdr (assoc 050 b)) 0.001) 
                            (equal (setq z (cdr (assoc 210 a))) (cdr (assoc 210 b)) 0.001) 
                            (setq n (list (cos r) (sin r))) 
                            (equal 
                                (car (trans (cdr (assoc 10 a)) z n)) 
                                (car (trans (cdr (assoc 10 b)) z n)) 
                                0.001 
                            ) 
                        ) 
                    ) 
                ) 
                (if (cdr g) 
                    (progn 
                        (setq g 
                            (vl-sort g 
                                (function 
                                    (lambda ( a b / n r z ) 
                                        (setq r (cdr (assoc 050 a)) 
                                              z (cdr (assoc 210 a)) 
                                              n (list (cos r) (sin r)) 
                                        ) 
                                        (<  (last (trans (cdr (assoc 10 a)) z n)) 
                                            (last (trans (cdr (assoc 10 b)) z n)) 
                                        ) 
                                    ) 
                                ) 
                            ) 
                        ) 
                        (entmod 
                            (subst 
                                (cons  1 (apply 'strcat (mapcar '(lambda ( x ) (cdr (assoc 1 x))) g))) 
                                (assoc 1 (car g)) 
                                (car g) 
                            ) 
                        ) 
                        (foreach e (cdr g) (entdel (cdr (assoc -1 e)))) 
                    ) 
                ) 
            )                   
        ) 
    ) 
    (princ) 
) 
 
;; Group By Function  -  Lee Mac 
;; Groups items considered equal by a given predicate function 
 
(defun LM:GroupByFunction ( lst fun / tmp1 tmp2 x1 ) 
    (if (setq x1 (car lst)) 
        (progn 
            (foreach x2 (cdr lst) 
                (if (fun x1 x2) 
                    (setq tmp1 (cons x2 tmp1)) 
                    (setq tmp2 (cons x2 tmp2)) 
                ) 
            ) 
            (cons (cons x1 (reverse tmp1)) (LM:GroupByFunction (reverse tmp2) fun)) 
        ) 
    ) 
) 
 
(princ)

marting · 发表于 2017-5-24 09:41:01

我也发个版本

(defun c:CombindText (/ ACTDOC L S)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(if (and (setq l (ssget '((0 . "TEXT"))))
(setq s (getstring T "\n Enter string to place in between text strings [enter for none]: ")))
(progn
(setq l
(vl-sort
(mapcar
(function (lambda (x) (list (cdr (assoc 10 (entget x))) (cdr (assoc 1 (entget x))) x))
) ;_ function
(vl-remove-if
(function listp)
(mapcar (function cadr) (ssnamex l))
) ;_ vl-remove-if
) ;_ mapcar
(function
(lambda (a b)
(or
(and
(equal (cadar a) (cadar b) 1e-3)
(< (caar a) (caar b))
) ;_ and
(< (cadar a) (cadar b))
) ;_ or
) ;_ lambda
) ;_ function
) ;_ vl-sort
) ;_ setq
(while l
(if (equal (cadaar l) (cadr (caadr l)) 1e-3)
(progn
(entdel (last (cadr l)))
(setq l (cons (list (caar l) (strcat (cadar l) s (cadadr l)) (caddar l)) (cddr l)))
) ;_ progn
(progn
(entmod (subst (cons 1 (cadar l)) (assoc 1 (entget (caddar l))) (entget (caddar l))))
(entupd (caddar l))
(setq l (cdr l))
) ;_ progn
) ;_ if
) ;_ while
) ;_ progn
) ;_ if
(vla-EndUndoMark ActDoc)
(princ)
)

(defun c:CombindText (/ ACTDOC L S) 
  (setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object))) 
  (vla-EndUndoMark ActDoc) 
  (vla-StartUndoMark ActDoc) 
  (if (and (setq l (ssget '((0 . "TEXT")))) 
         (setq s (getstring T "\n Enter string to place in between text strings [enter for none]: "))) 
     (progn 
       (setq l 
              (vl-sort 
                (mapcar 
                  (function (lambda (x) (list (cdr (assoc 10 (entget x))) (cdr (assoc 1 (entget x))) x)) 
                  ) ;_  function 
                  (vl-remove-if 
                    (function listp) 
                    (mapcar (function cadr) (ssnamex l)) 
                  ) ;_  vl-remove-if 
                ) ;_  mapcar 
                (function 
                  (lambda (a b) 
                    (or 
                      (and 
                        (equal (cadar a) (cadar b) 1e-3) 
                        (< (caar a) (caar b)) 
                      ) ;_  and 
                      (< (cadar a) (cadar b)) 
                    ) ;_  or 
                  ) ;_  lambda 
                ) ;_  function 
              ) ;_  vl-sort 
       ) ;_  setq 
       (while l 
         (if (equal (cadaar l) (cadr (caadr l)) 1e-3) 
           (progn 
             (entdel (last (cadr l))) 
             (setq l (cons (list (caar l) (strcat (cadar l) s (cadadr l)) (caddar l)) (cddr l))) 
           ) ;_  progn 
           (progn 
             (entmod (subst (cons 1 (cadar l)) (assoc 1 (entget (caddar l))) (entget (caddar l)))) 
             (entupd (caddar l)) 
             (setq l (cdr l)) 
           ) ;_  progn 
         ) ;_  if 
       ) ;_  while 
     ) ;_  progn 
  ) ;_  if 
  (vla-EndUndoMark ActDoc) 
  (princ) 
)

Lisphk · 发表于 2017-5-24 08:48:57

另外个版本：

(defun c:GatherTexts (/ ss i sn e lst l st)
;;;;; Tharwat 01. Nov. 2012 ;;;;;
;;;;; gathering TEXT entities all together in ;;;;;
;;;;; the first left entity from the selection set ;;;;;
(or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
(if (setq ss (ssget "_:L" '((0 . "TEXT"))))
(progn (repeat (setq i (sslength ss))
(setq sn (ssname ss (setq i (1- i))))
(setq e (entget sn))
(setq lst (cons (list (cdr (assoc 10 e)) (cdr (assoc 1 e)) sn) lst))
)
(setq l (vl-sort lst '(lambda (a b) (< (car (car a)) (car (car b))))))
(setq st (apply 'strcat (mapcar 'cadr l)))
(vla-StartUndoMark acdoc)
(if (entmod (subst (cons 1 st) (assoc 1 (entget (caddr (car l)))) (entget (caddr (car l)))))
(progn (setq l (reverse l)) (setq l (vl-remove (last l) l)) (mapcar 'entdel (mapcar 'caddr l)))
)
(vla-EndUndomark acdoc)
)
(princ)
)
(princ)
)

(defun c:GatherTexts (/ ss i sn e lst l st) 
;;;;;            Tharwat 01. Nov. 2012            ;;;;; 
;;;;;        gathering TEXT entities all together in        ;;;;; 
;;;;;        the first left entity from the selection set    ;;;;; 
  (or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))) 
   
  (if (setq ss (ssget "_:L" '((0 . "TEXT")))) 
    (progn (repeat (setq i (sslength ss)) 
             (setq sn (ssname ss (setq i (1- i)))) 
             (setq e (entget sn)) 
             (setq lst (cons (list (cdr (assoc 10 e)) (cdr (assoc 1 e)) sn) lst)) 
           ) 
           (setq l (vl-sort lst '(lambda (a b) (< (car (car a)) (car (car b)))))) 
           (setq st (apply 'strcat (mapcar 'cadr l))) 
           (vla-StartUndoMark acdoc) 
           (if (entmod (subst (cons 1 st) (assoc 1 (entget (caddr (car l)))) (entget (caddr (car l))))) 
             (progn (setq l (reverse l)) (setq l (vl-remove (last l) l)) (mapcar 'entdel (mapcar 'caddr l))) 
           ) 
           (vla-EndUndomark acdoc) 
    ) 
    (princ) 
  ) 
  (princ) 
)

另外一个版本

游客，如果您要查看本帖隐藏内容请回复

q3_2006 · 发表于 2017-5-24 08:52:44

这个用来处理炸开的多行文本比较好...

HLCAD · 发表于 2017-5-24 09:00:31

非常好的程序，谢谢楼主分享！

fangmin723 · 发表于 2017-5-24 16:33:24

虽然用处不大，但也值得学习！

関吣 · 发表于 2017-5-24 21:59:00

本帖最后由関吣于 2017-5-24 22:04 编辑

第一个版本加个模糊距离就完美了，要不然同一直线上的文本全合一起了，
第二个版本竖向的文本全部合到一块，
第三个版本想看一下~
谢谢版主。

kqqt6236 · 发表于 2017-5-25 00:05:36

谢谢分享。

laiz3000 · 发表于 2017-5-25 00:50:28

感谢分享程序

longer1000 · 发表于 2017-5-25 00:59:16

非常好的程序，谢谢楼主

liunian0524 · 发表于 2017-5-25 07:51:01

感谢楼主分享

freefor5127 · 发表于 2017-5-26 22:08:50

能合成多行文本吗？

newer · 发表于 2017-5-26 22:10:42

freefor5127 发表于 2017-5-26 22:08

文字转多行文本论坛有插件，搜索下。

ynhh · 发表于 2017-5-28 12:57:46

看上去还不错啊
谢谢

hao3ren · 发表于 2017-5-28 18:57:09

同一行的全部处理到一块吗？

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

[每日一码] 散开的单个文字合并成单行的文字实体

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。