判断文字压盖
请求高手帮忙: 所选图中的（单行）文字，如果文字有互相压盖的，则把此文字颜色变成绿色。谢谢！ ;;---------------------=={ Get Text Box }==-------------------;;;; ;;
;;Returns a point list describing a rectangle framing the ;;
;;specified text or mtext entity with optional offset ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ?2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;ent - Text or MText ename ;;
;;off - offset (may be zero) ;;
;;------------------------------------------------------------;;
;;Returns:List of Points (in OCS) describing text frame ;;
;;------------------------------------------------------------;;
(defun LM:GetTextBox ( ent off / dx lst base rotn norm w h matrix )
;; ?Lee Mac 2010
(setq dx (lambda ( x l ) (cdr (assoc x l))))
(if
(setq lst
(cond
(
(eq "TEXT" (dx 0 (setq l (entget ent))))
(setq base (dx 10 l) rotn (dx 50 l))
(
(lambda ( data )
(mapcar
(function
(lambda ( funcs )
(mapcar
(function
(lambda ( func )
((eval (car func)) ((eval (cdr func)) data) off)
)
)
funcs
)
)
)
(list
(list (cons '- 'caar ) (cons '- 'cadar ))
(list (cons '+ 'caadr) (cons '- 'cadar ))
(list (cons '+ 'caadr) (cons '+ 'cadadr))
(list (cons '- 'caar ) (cons '+ 'cadadr))
)
)
)
(textbox l)
)
)
(
(eq "MTEXT" (dx 0 l))
(setq norm (dx 210 l) base (trans (dx 10 l) 0 norm)
rotn (angle '(0. 0. 0.) (trans (dx 11 l) 0 norm))
w (dx 42 l) h (dx 43 l)
)
(
(lambda ( org )
(mapcar
(function
(lambda ( o ) (mapcar '+ org o))
)
(list
(list (- off) (- off))
(list (+ w off) (- off))
(list (+ w off) (+ h off))
(list (- off) (+ h off))
)
)
)
(
(lambda ( j )
(list
(cond
(
(member j '(2 5 8)) (/ w -2.)
)
(
(member j '(3 6 9)) (- w)
)
( 0. )
)
(cond
(
(member j '(1 2 3)) (- h)
)
(
(member j '(4 5 6)) (/ h -2.)
)
( 0. )
)
)
)
(dx 71 l)
)
)
)
)
)
(progn
(setq matrix
(list
(list (cos rotn) (sin (- rotn)) 0.)
(list (sin rotn) (cos rotn)0.)
(list 0. 0. 1.)
)
)
(mapcar
(function
(lambda ( point )
(mapcar '+
(mapcar
(function
(lambda ( r ) (apply '+ (mapcar '* r point)))
)
matrix
)
(reverse (cdr (reverse base)))
)
)
)
lst
)
)
)
) 选求得文字四个角点，然后(ssget "CW" '(list p1 p2 p3 p4) '((0 . *Text))) 谢谢，能给我完整的代码吗？非常感谢！我是菜鸟…… 谢谢，运行后提示参数太少。 利用地板的函数，给你做了个，看看是否合用。
(vl-load-com)
(defun c:gt1(/ sstext text_sn cpl i)
(setq sstext (ssget '((0 . "text"))))
(if sstext
(progn
(setq i 0)
(repeat (sslength sstext)
(setq text_sn (ssname sstext i)
plst (LM:GetTextBox text_sn 0)
cpl (ssget "CP" plst '((0 . "text")))
)
(if (> (sslength cpl) 1)
(vla-put-color (vlax-ename->vla-object text_sn) 3)
)
(setq i (1+ i))
))))
819534890 发表于 2014-6-12 17:52
利用地板的函数，给你做了个，看看是否合用。
非常感谢！能实现检查功能了。只不过文字样式似乎有影响，如果文字样式为宋体，选择过多会提示参数错误。如果样式为hz则不会提示错误。能优化此问题吗？
页:
[1]