(XD::Text:Box1)通用版本的文本实际包围盒函数

Lispboy · 发表于 2013-7-26 09:35:02

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

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

×

;|
求TEXT实体的实际包围盒
参数：
e --- 实体名
返回值：
包围盒（UCS点）
|;
(defun XD::Text:Box (e / el l l1 l2 p1 p10 p2 str str0 v x)
(setq el (entget e)
p10 (cdr (assoc 10 el))
str (cdr (assoc 1 el))
str0 ""
l (textbox el)
)
(while (= (ascii str) 32)
(setq str0 (strcat str0 " ")
str (substr str 2)
)
)
(if (= str0 "")
l
(progn
(setq l1 (textbox (subst
(cons 1 (strcat "A" str0 "A"))
(assoc 1 el)
el
)
)
l2 (textbox (subst
(cons 1 (strcat str0 "AA"))
(assoc 1 el)
el
)
)
l1 (mapcar'- (cadr l1) (cadr l2))
p1 (mapcar'+ (car l) l1)
p2 (mapcar'+ (cadr l) l1)
)
(setq l (list p1 p2))
)
)
(setq l (mapcar
'(lambda (x)
(mapcar
'+
(trans p10 0 1)
x
)
)
l
)
)
(setq v (mapcar
'-
(cadr l)
(car l)
)
)
(list (car l)
(mapcar '+ (car l)(list (car v) 0.0 0.0))
(cadr l)
(mapcar '+ (car l)(list 0 (cadr v) 0.0))
)
)

;| 
求TEXT实体的实际包围盒 
参数： 
   e  ---  实体名 
返回值： 
   包围盒（UCS点） 
|; 
(defun XD::Text:Box (e / el l l1 l2 p1 p10 p2 str str0 v x) 
  (setq el (entget e) 
        p10 (cdr (assoc 10 el)) 
        str (cdr (assoc 1 el)) 
        str0 "" 
        l (textbox el) 
  ) 
  (while (= (ascii str) 32) 
    (setq str0 (strcat str0 " ") 
          str (substr str 2) 
    ) 
  ) 
  (if (= str0 "") 
    l 
    (progn 
      (setq l1 (textbox (subst 
                          (cons 1 (strcat "A" str0 "A")) 
                          (assoc 1 el) 
                          el 
                        ) 
               ) 
            l2 (textbox (subst 
                          (cons 1 (strcat str0 "AA")) 
                          (assoc 1 el) 
                          el 
                        ) 
               ) 
            l1 (mapcar'- (cadr l1) (cadr l2)) 
            p1 (mapcar'+ (car l) l1) 
            p2 (mapcar'+ (cadr l) l1) 
      ) 
      (setq l (list p1 p2)) 
    ) 
  ) 
  (setq l (mapcar 
            '(lambda (x) 
               (mapcar 
                 '+ 
                 (trans p10 0 1) 
                 x 
               ) 
             ) 
            l 
          ) 
  ) 
  (setq v (mapcar 
            '- 
            (cadr l) 
            (car l) 
          ) 
  ) 
  (list (car l) 
        (mapcar '+ (car l)(list (car v) 0.0 0.0)) 
        (cadr l) 
        (mapcar  '+ (car l)(list 0 (cadr v) 0.0)) 
  ) 
)

wowan1314 · 发表于 2013-7-26 10:23:44

a a

;TEXT的四个交点坐标
(defun t11 (ent / p0 p12 ang lst)
(setq ent (entget ent)
p0 (cdr (assoc 10 ent))
ang (cdr (assoc 50 ent))
p12 (textbox ent)
lst
(list
(car p12)
(list (caar p12)(cadadr p12))
(cadr p12)
(list (caadr p12)(cadar p12))
)
)
(mapcar '(lambda(x)(polar p0 (+ ang (angle '(0 0) x)) (distance '(0 0) x))) lst)
)

1993063 · 发表于 2013-7-27 01:26:37

楼上两位都成了发帖达人了:D

ucuc2003 · 发表于 2013-7-28 17:26:33

谢谢楼主分享通用版本的文本实际包围盒函数 @！

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

[文本] (XD::Text:Box1)通用版本的文本实际包围盒函数

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