相同文字连线改进

弘毅

这个是论坛一个前辈在13年写的代码，可以把相同的文字变色并且连线，我想加上一个功能 ，能不能是选中指定的文字连线呢？
下面是代码：
(defun c:tt (/ doc ms ss ll clyr)
  (vl-load-com)
  (setq doc  (vla-get-activedocument (vlax-get-acad-object))
ms   (vla-get-modelspace doc)
clyr (getvar "clayer")
  )
  (vla-startundomark doc)
  (if (setq ss (ssget '((0 . "Text"))))
    (vl-catch-all-apply
      (function
(lambda (/ sl i e el str p)
   (if (not (tblsearch "layer" "xt"))
     (vl-cmdf ".layer" "m" "Xt" "c" "3" "" "")
   )
   (setq sl (sslength ss)
  i  -1
   )
   (repeat sl
     (setq e   (ssname ss (setq i (1+ i)))
    el  (entget e)
    str (strcat "fy" (cdr (assoc 1 el)))
    p   (cdr (assoc 10 el))
    p   (list (car p) (cadr p))
     )
     (set (read str) (cons (list p el) (eval (read str))))
     (if (vl-position str ll)
       nil
       (setq ll (cons str ll))
     )
   )
   (mapcar '(lambda (x / l pl)
       (setq l
       (apply
         'append
         (vl-sort
    (mapcar 'car x)
    '(lambda (e1 e2)
       (if
         (equal (car e1) (car e2) 1e-3)
          (< (cadr e1) (cadr e2))
          (< (car e1) (car e2))
       )
     )
         )
       )
       )
       (mapcar '(lambda (y)
    (entmod (append y '((62 . 3))))
         )
        (mapcar 'cadr x)
       )
       (setq
         pl (vla-addlightweightpolyline
       ms
       (vlax-make-variant
         (vlax-safearray-fill
    (vlax-make-safearray
      vlax-vbdouble
      (cons 0 (1- (length l)))
    )
    l
         )
       )
     )
       )
       (vla-put-layer pl "xt")
       (vla-put-color pl acred)
     )
    (vl-remove-if
      '(lambda (x) (= (length x) 1))
      (mapcar 'eval (mapcar 'read ll))
    )
   )
)
      )
    )
  )
  (vla-endundomark doc)
  (setvar "clayer" clyr)
  (if ll
    (mapcar '(lambda (x) (set (read x) nil)) ll)
  )
  (vlax-release-object doc)
  (vlax-release-object ms)
  (princ)
)

wxd1354

相同文字连线的插件能发我一下吗

huangpc27

修改一下就能用到图块连线了，非常不错