相同文字连线如何加入属性块文字
;;--------------相同文字连线----------------(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))))
)
)
上述程序如何加入属性块文字？有请高手出手
(defun c:tt (/ *ent2obj* entbox get-dxf getmidpo olayer oldliness po px ss ss2list sslst str str2 ttent tylx)
(setq *ent2obj* vlax-Ename->Vla-Object)
;;单个物体的最小（正交）包围框
(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 )
(reverse (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss))))
)
(defun get-dxf(en n)
(if (not (listp en)) (setq en (entget en)))
(cdr (assoc n en))
)
(setq olayer (getvar "clayer"))
(command "layer" "m" "f_temp_文字连线" "c" "6" "" "")
(setvar "cmdecho" 0)
(if (setq ss (ssget ":e:s" '(
(-4 . "<OR")
(-4 . "<AND")(0 . "TEXT")(-4 . "AND>")
(-4 . "<AND")(0 . "INSERT")(66 . 1)(-4 . "AND>")
(-4 . "OR>")
)
)
)
(progn
(setq ttent (ssname ss 0))
(setq tylx (get-dxf ttent 0))
(cond
((= tylx "TEXT")
(setq str (cdr (assoc 1 (entget ttent))))
)
((= tylx "INSERT")
(setq str (car (mapcar '(lambda (x) (vla-get-textstring x)) (vlax-invoke (vlax-ename->vla-object ttent) "getattributes"))))
)
)
(setq po (getmidpo (entbox ttent)))
(setq ss (ssget "x" (list
'(-4 . "<OR")
'(-4 . "<AND")'(0 . "TEXT")(cons 1 str)'(-4 . "AND>")
'(-4 . "<AND")'(0 . "INSERT")'(66 . 1)'(-4 . "AND>")
'(-4 . "OR>")
)
)
)
(setq sslst '())
(foreach ty (ss2list ss)
(setq tylx (get-dxf ty 0))
(if (= tylx "INSERT")
(progn
(setq str2 (car (mapcar '(lambda (x) (vla-get-textstring x)) (vlax-invoke (vlax-ename->vla-object ty) "getattributes"))))
(if (/= str str2)
(ssdel ty ss)
)
)
)
)
(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" "")
)
)
)
(setvar "clayer" olayer)
(princ)
)
(setq ss (ssget ":e:s" '((0 . "TEXT,attdef")))) 自贡黄明儒 发表于 2024-2-18 10:02
(setq ss (ssget ":e:s" '((0 . "TEXT,attdef"))))
这个取不到属性块的文字(setq str (cdr (assoc 1 (entget ttent)))) 飞雪神光 发表于 2024-2-18 09:29
谢谢飞雪的程序 完美 感谢飞雪大神的分享，牛
页:
[1]