相同文字连线如何加入属性块文字

szx025

;;--------------相同文字连线----------------
(setq *ent2obj*     vlax-Ename->Vla-Object)

(defun c:tt()
  (if (setq ss (ssget ":e:s" '((0 . "TEXT"))))
  (progn
   (setq ttent (ssname ss 0))
   (command "layer" "m" "f_temp_文字连线" "c" "6" "" "")
   (setq str (cdr (assoc 1 (entget ttent))))
   (setq po (getmidpo (entbox ttent)))
   (setq ss (ssget "x" (list '(0 . "TEXT")(cons 1 str))))
   (if (< 1 (sslength ss))
    (progn
     (setq oldliness (ssget "x" '((0 . "line")(8 . "f_temp_文字连线"))))
     (if oldliness (command "erase" oldliness ""))

     (setq ss (vl-remove ttent (ss2list ss)))
     (foreach x ss
      (setq px (getmidpo (entbox x)))
      (command "line" "non" po "non" px "")
     )
    )
    (command "change" ttent "" "p" "co" "2" "")
   )
  )
)
(princ)
)

;;单个物体的最小（正交）包围框
(defun entbox ( ent / ll ur )
(vla-getboundingbox (*ent2obj* ent) 'll 'ur)
(mapcar 'vlax-safearray->list (list ll ur))
)

;;求两点中点
(defun getmidpo( pts / P1 P2 X Y )
(setq p1 (car pts) p2 (cadr pts))
(if (= (length p1) (length p2))
  nil
  (setq p1 (list (car p1) (cadr p1))
    p2 (list (car p2) (cadr p2))
  )
)
(mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)
)

;;选择集转为图元列表
(defun ss2list( ss )
(if (= 'PICKSET (type ss))
  (reverse (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss))))
)
)
上述程序如何加入属性块文字？有请高手出手

飞雪神光

1. (defun c:tt (/ *ent2obj* entbox get-dxf getmidpo olayer oldliness po px ss ss2list sslst str str2 ttent tylx)
   
2.   (setq *ent2obj*     vlax-Ename->Vla-Object)
   
3.   ;;单个物体的最小（正交）包围框
   
4.   (defun entbox ( ent / ll ur )
   
5.     (vla-getboundingbox (*ent2obj* ent) 'll 'ur)
   
6.     (mapcar 'vlax-safearray->list (list ll ur))
   
7.   )
   
8.   ;;求两点中点
   
9.   (defun getmidpo( pts / P1 P2 X Y )
   
10.     (setq p1 (car pts) p2 (cadr pts))
    
11.     (if (= (length p1) (length p2))
    
12.       nil
    
13.       (setq p1 (list (car p1) (cadr p1))
    
14.         p2 (list (car p2) (cadr p2))
    
15.       )
    
16.     )
    
17.     (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)
    
18.   )
    
19.   ;;选择集转为图元列表
    
20.   (defun ss2list( ss )
    
21.     (reverse (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss))))
    
22.   )
    
23.   (defun get-dxf(en n)
    
24.     (if (not (listp en)) (setq en (entget en)))
    
25.     (cdr (assoc n en))
    
26.   )
    
27.   (setq olayer (getvar "clayer"))
    
28.   (command "layer" "m" "f_temp_文字连线" "c" "6" "" "")
    
29.   (setvar "cmdecho" 0)
    
30.   (if (setq ss (ssget ":e:s" '(
    
31.                                 (-4 . "<OR")
    
32.                                 (-4 . "<AND")(0 . "TEXT")(-4 . "AND>")
    
33.                                 (-4 . "<AND")(0 . "INSERT")(66 . 1)(-4 . "AND>")
    
34.                                 (-4 . "OR>")
    
35.                               )
    
36.                )
    
37.       )
    
38.     (progn
    
39.       (setq ttent (ssname ss 0))
    
40.       (setq tylx (get-dxf ttent 0))
    
41.       (cond
    
42.         ((= tylx "TEXT")
    
43.           (setq str (cdr (assoc 1 (entget ttent))))
    
44.         )
    
45.         ((= tylx "INSERT")
    
46.           (setq str (car (mapcar '(lambda (x) (vla-get-textstring x)) (vlax-invoke (vlax-ename->vla-object ttent) "getattributes"))))
    
47.         )
    
48.       )
    
49.       (setq po (getmidpo (entbox ttent)))
    
50.       (setq ss (ssget "x" (list
    
51.                             '(-4 . "<OR")
    
52.                             '(-4 . "<AND")'(0 . "TEXT")(cons 1 str)'(-4 . "AND>")
    
53.                             '(-4 . "<AND")'(0 . "INSERT")'(66 . 1)'(-4 . "AND>")
    
54.                             '(-4 . "OR>")
    
55.                           )
    
56.                )
    
57.       )
    
58.       (setq sslst '())
    
59.       (foreach ty (ss2list ss)
    
60.         (setq tylx (get-dxf ty 0))
    
61.         (if (= tylx "INSERT")
    
62.           (progn
    
63.             (setq str2 (car (mapcar '(lambda (x) (vla-get-textstring x)) (vlax-invoke (vlax-ename->vla-object ty) "getattributes"))))
    
64.             (if (/= str str2)
    
65.               (ssdel ty ss)
    
66.             )
    
67.           )
    
68.         )
    
69.       )
    
70.       (if (< 1 (sslength ss))
    
71.         (progn
    
72.           (setq oldliness (ssget "x" '((0 . "line")(8 . "f_temp_文字连线"))))
    
73.           (if oldliness (command "erase" oldliness ""))
    
74.           (setq ss (vl-remove ttent (ss2list ss)))
    
75.           (foreach x ss
    
76.             (setq px (getmidpo (entbox x)))
    
77.             (command "line" "non" po "non" px "")
    
78.           )
    
79.         )
    
80.         (command "change" ttent "" "p" "co" "2" "")
    
81.       )
    
82.     )
    
83.   )
    
84.   (setvar "clayer" olayer)
    
85.   (princ)
    
86. )

(defun c:tt (/ *ent2obj* entbox get-dxf getmidpo olayer oldliness po px ss ss2list sslst str str2 ttent tylx)<br />   (setq *ent2obj*     vlax-Ename->Vla-Object)<br />   ;;单个物体的最小（正交）包围框<br />   (defun entbox ( ent / ll ur )<br />     (vla-getboundingbox (*ent2obj* ent) 'll 'ur)<br />     (mapcar 'vlax-safearray->list (list ll ur))<br />   )<br />   ;;求两点中点<br />   (defun getmidpo( pts / P1 P2 X Y )<br />     (setq p1 (car pts) p2 (cadr pts))<br />     (if (= (length p1) (length p2))<br />       nil<br />       (setq p1 (list (car p1) (cadr p1))<br />         p2 (list (car p2) (cadr p2))<br />       )<br />     )<br />     (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)<br />   )<br />   ;;选择集转为图元列表<br />   (defun ss2list( ss )<br />     (reverse (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss))))<br />   )<br />   (defun get-dxf(en n)<br />     (if (not (listp en)) (setq en (entget en)))<br />     (cdr (assoc n en))<br />   )<br />   (setq olayer (getvar "clayer"))<br />   (command "layer" "m" "f_temp_文字连线" "c" "6" "" "")<br />   (setvar "cmdecho" 0)<br />   (if (setq ss (ssget ":e:s" '(<br />                                 (-4 . "<OR")<br />                                 (-4 . "<AND")(0 . "TEXT")(-4 . "AND>")<br />                                 (-4 . "<AND")(0 . "INSERT")(66 . 1)(-4 . "AND>")<br />                                 (-4 . "OR>")<br />                               )<br />                )<br />       )<br />     (progn<br />       (setq ttent (ssname ss 0))<br />       (setq tylx (get-dxf ttent 0))<br />       (cond <br />         ((= tylx "TEXT")<br />           (setq str (cdr (assoc 1 (entget ttent))))<br />         )<br />         ((= tylx "INSERT")<br />           (setq str (car (mapcar '(lambda (x) (vla-get-textstring x)) (vlax-invoke (vlax-ename->vla-object ttent) "getattributes"))))<br />         )<br />       )<br />       (setq po (getmidpo (entbox ttent)))<br />       (setq ss (ssget "x" (list<br />                             '(-4 . "<OR")<br />                             '(-4 . "<AND")'(0 . "TEXT")(cons 1 str)'(-4 . "AND>")<br />                             '(-4 . "<AND")'(0 . "INSERT")'(66 . 1)'(-4 . "AND>")<br />                             '(-4 . "OR>")<br />                           )<br />                )<br />       )<br />       (setq sslst '())<br />       (foreach ty (ss2list ss)<br />         (setq tylx (get-dxf ty 0))<br />         (if (= tylx "INSERT")<br />           (progn<br />             (setq str2 (car (mapcar '(lambda (x) (vla-get-textstring x)) (vlax-invoke (vlax-ename->vla-object ty) "getattributes"))))<br />             (if (/= str str2)<br />               (ssdel ty ss)<br />             )<br />           )<br />         )<br />       )<br />       (if (< 1 (sslength ss))<br />         (progn<br />           (setq oldliness (ssget "x" '((0 . "line")(8 . "f_temp_文字连线"))))<br />           (if oldliness (command "erase" oldliness ""))<br />           (setq ss (vl-remove ttent (ss2list ss)))<br />           (foreach x ss<br />             (setq px (getmidpo (entbox x)))<br />             (command "line" "non" po "non" px "")<br />           )<br />         )<br />         (command "change" ttent "" "p" "co" "2" "")<br />       )<br />     )<br />   )<br />   (setvar "clayer" olayer)<br />   (princ)<br /> )

自贡黄明儒

(setq ss (ssget ":e:s" '((0 . "TEXT,attdef"))))

szx025

自贡黄明儒 发表于 2024-2-18 10:02
(setq ss (ssget ":e:s" '((0 . "TEXT,attdef"))))

这个取不到属性块的文字(setq str (cdr (assoc 1 (entget ttent))))

szx025

飞雪神光 发表于 2024-2-18 09:29

谢谢飞雪的程序 完美

paulpipi

感谢飞雪大神的分享，牛