绘制块实体属性文字的文字框

newer · 发表于 2017-7-14 18:49:46

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

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

×

(defun c:test ( / ent enx idx sel )
(if (setq sel (ssget '((0 . "INSERT") (66 . 1))))
(repeat (setq idx (sslength sel))
(setq ent (entnext (ssname sel (setq idx (1- idx))))
enx (entget ent)
)
(while (= "ATTRIB" (cdr (assoc 0 enx)))
(entmake
(append
'(
(000 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(090 . 4)
(070 . 1)
)
(list (cons 38 (cadddr (assoc 10 enx))))
(mapcar '(lambda ( p ) (cons 10 p)) (LM:textbox ent))
(list (assoc 210 enx))
)
)
(setq ent (entnext ent)
enx (entget ent)
)
)
)
)
(princ)
)
;; Text Box - Lee Mac
;; A wrapper for the textbox function to return the bounding box of a Text or Attrib (in OCS)
(defun LM:textbox ( ent / ins mat rot )
(setq ent (entget ent)
ins (cdr (assoc 10 ent))
rot (cdr (assoc 50 ent))
mat (list
(list (cos rot) (sin (- rot)) 0.0)
(list (sin rot) (cos rot) 0.0)
'(0.0 0.0 1.0)
)
)
(mapcar '(lambda ( x ) (mapcar '+ (mxv mat x) ins)) (LM:points->boundingbox (textbox ent)))
)
;; Points to Bounding Box - Lee Mac
;; Returns the rectangular extents of a supplied point list
(defun LM:points->boundingbox ( lst )
( (lambda ( l )
(mapcar '(lambda ( a ) (mapcar '(lambda ( b ) ((eval b) l)) a))
'(
(caar cadar)
(caadr cadar)
(caadr cadadr)
(caar cadadr)
)
)
)
(mapcar '(lambda ( f ) (apply 'mapcar (cons f lst))) '(min max))
)
)

(defun c:test ( / ent enx idx sel ) 
    (if (setq sel (ssget '((0 . "INSERT") (66 . 1)))) 
        (repeat (setq idx (sslength sel)) 
            (setq ent (entnext (ssname sel (setq idx (1- idx)))) 
                  enx (entget ent) 
            ) 
            (while (= "ATTRIB" (cdr (assoc 0 enx))) 
                (entmake 
                    (append 
                       '( 
                            (000 . "LWPOLYLINE") 
                            (100 . "AcDbEntity") 
                            (100 . "AcDbPolyline") 
                            (090 . 4) 
                            (070 . 1) 
                        ) 
                        (list (cons 38 (cadddr (assoc 10 enx)))) 
                        (mapcar '(lambda ( p ) (cons 10 p)) (LM:textbox ent)) 
                        (list (assoc 210 enx)) 
                    ) 
                ) 
                (setq ent (entnext ent) 
                      enx (entget  ent) 
                ) 
            ) 
        ) 
    ) 
    (princ) 
) 
 
;; Text Box  -  Lee Mac 
;; A wrapper for the textbox function to return the bounding box of a Text or Attrib (in OCS) 
 
(defun LM:textbox ( ent / ins mat rot ) 
    (setq ent (entget ent) 
          ins (cdr (assoc 10 ent)) 
          rot (cdr (assoc 50 ent)) 
          mat (list 
                  (list (cos rot) (sin (- rot)) 0.0) 
                  (list (sin rot) (cos rot)     0.0) 
                 '(0.0 0.0 1.0) 
              ) 
    ) 
    (mapcar '(lambda ( x ) (mapcar '+ (mxv mat x) ins)) (LM:points->boundingbox (textbox ent))) 
) 
 
;; Points to Bounding Box  -  Lee Mac 
;; Returns the rectangular extents of a supplied point list 
 
(defun LM:points->boundingbox ( lst ) 
    (   (lambda ( l ) 
            (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) ((eval b) l)) a)) 
               '( 
                    (caar   cadar) 
                    (caadr  cadar) 
                    (caadr cadadr) 
                    (caar  cadadr) 
                ) 
            ) 
        ) 
        (mapcar '(lambda ( f ) (apply 'mapcar (cons f lst))) '(min max)) 
    ) 
)

函数 MXV：

;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
(princ)

kqqt6236 · 发表于 2017-7-15 00:23:01

谢谢分享。

longer1000 · 发表于 2017-7-15 01:59:28

yoyoho · 发表于 2017-7-15 07:19:57

感谢分享，学习了！

yangjian001 · 发表于 2017-7-15 07:45:02

wewehua · 发表于 2021-7-25 21:01:23

好像用不了呀

wewehua · 发表于 2021-8-4 16:14:57

不知道什么原因，用不了

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

[每日一码] 绘制块实体属性文字的文字框

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

浏览过的版块