Display Field Objects

Free-Lancer · 发表于 2013-8-21 20:40:29

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

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

×

;;----------------=={ Display Field Objects }==---------------;;;;
;;;; Prompts user to select a field linked to one or more
;;;; objects, then displays which objects are linked to the
;;;; selected field.
;;;;------------------------------------------------------------
;;;; Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com
;;;;------------------------------------------------------------
;;;; Version 1.0 - 04-11-2011
;;;;------------------------------------------------------------;;
(defun c:FieldObjects (/ *error* _corners->list
_offsetoutside _midpoint _inters-box-point
_outline _getfieldobjects
_selectif a b
c d e
)
(defun *error* (m) (redraw) (princ))
(defun _corners->list (a b)
(mapcar (function (lambda (a b) (list (car a) (cadr B))))
(list a b b a)
(list a a b B)
)
)
(defun _offsetoutside (a b)
(mapcar (function
(lambda (a c)
(mapcar (function (lambda (a c) ((eval a) c B))) a c)
)
)
'((- -) (+ -) (+ +) (- +))
a
)
)
(defun _midpoint (a b)
(mapcar (function (lambda (a b) (/ (+ a B) 2.))) a b)
)
(defun _inters-box-point (a b c)
(vl-some (function (lambda (d e) (inters b c d e)))
a
(cons (last a) a)
)
)
(defun _outline (a b c d e / f g)
(mapcar (function (lambda (a b) (grdraw a b e 1)))
a
(cons (last a) a)
)
(if (and c
(setq f (_inters-box-point a b d))
(setq g (_inters-box-point c d B))
)
(grdraw f g 2 1)
)
)
(defun _getfieldobjects (a / __getfieldobjects)
(defun __getfieldobjects (a)
(apply 'append
(mapcar (function (lambda (b)
(if (= 360 (car B))
(__getfieldobjects (cdr B))
(if (= 331 (car B))
(list (cdr B))
)
)
)
)
(entget a)
)
)
)
(if (and (wcmatch (cdr (assoc 0 (setq a (entget a))))
"TEXT,MTEXT,ATTRIB"
)
(setq a (cdr (assoc 360 a)))
(setq a (dictsearch a "ACAD_FIELD"))
(setq a (dictsearch (cdr (assoc -1 a)) "TEXT"))
(setq a (cdr (assoc 360 a)))
)
(__getfieldobjects a)
)
)
(defun _selectif (a b / c d)
(setq b (eval B))
(while
(progn (setvar 'ERRNO 0)
(setq c (car (nentsel a)))
(cond ((= 7 (getvar 'ERRNO)) (princ "\nMissed, try again."))
((eq 'ENAME (type c))
(if (not (setq d (b c)))
(princ "\nInvalid Object.")
)
)
)
)
)
(if c
(cons c d)
)
)
(if (setq a
(mapcar (function
(lambda (a)
(vla-getboundingbox (vlax-ename->vla-object a) 'b 'c)
(setq b (vlax-safearray->list B)
c (vlax-safearray->list c)
)
(list (_corners->list b c) (_midpoint b c))
)
)
(_selectif "\nSelect Field: " '_getfieldobjects)
)
)
(progn
(princ "\nPress any key to Exit...")
(while (= 5 (car (setq b (grread t 9))))
(redraw)
(_outline (setq c (cadar a)
d (_offsetoutside (caar a) (/ (getvar 'VIEWSIZE) 50.))
)
nil
nil
nil
3
)
(foreach e (cdr a)
(_outline (_offsetoutside (car e) (/ (getvar 'VIEWSIZE) 50.))
(cadr e)
d
c
1
)
)
)
)
)
(redraw)
(princ)
)

;;----------------=={ Display Field Objects }==---------------;;;; 
;;;;  Prompts user to select a field linked to one or more 
;;;;  objects, then displays which objects are linked to the 
;;;;  selected field. 
;;;;------------------------------------------------------------ 
;;;;  Author: Lee Mac, Copyright ? 2011 - <a href=\"http://www.lee-mac.com\" target=\"_blank\">www.lee-mac.com</a> 
;;;;------------------------------------------------------------ 
;;;;  Version 1.0 -       04-11-2011 
;;;;------------------------------------------------------------;; 
(defun c:FieldObjects (/       *error*      _corners->list 
         _offsetoutside _midpoint      _inters-box-point 
         _outline       _getfieldobjects 
         _selectif      a       b 
         c       d       e 
        ) 
  (defun *error* (m) (redraw) (princ)) 
  (defun _corners->list (a b) 
    (mapcar (function (lambda (a b) (list (car a) (cadr B)))) 
     (list a b b a) 
     (list a a b B) 
    ) 
  ) 
  (defun _offsetoutside (a b) 
    (mapcar (function 
       (lambda (a c) 
  (mapcar (function (lambda (a c) ((eval a) c B))) a c) 
       ) 
     ) 
     '((- -) (+ -) (+ +) (- +)) 
     a 
    ) 
  ) 
  (defun _midpoint (a b) 
    (mapcar (function (lambda (a b) (/ (+ a B) 2.))) a b) 
  ) 
  (defun _inters-box-point (a b c) 
    (vl-some (function (lambda (d e) (inters b c d e))) 
      a 
      (cons (last a) a) 
    ) 
  ) 
  (defun _outline (a b c d e / f g) 
    (mapcar (function (lambda (a b) (grdraw a b e 1))) 
     a 
     (cons (last a) a) 
    ) 
    (if (and c 
      (setq f (_inters-box-point a b d)) 
      (setq g (_inters-box-point c d B)) 
 ) 
      (grdraw f g 2 1) 
    ) 
  ) 
  (defun _getfieldobjects (a / __getfieldobjects) 
    (defun __getfieldobjects (a) 
      (apply 'append 
      (mapcar (function (lambda (b) 
     (if (= 360 (car B)) 
       (__getfieldobjects (cdr B)) 
       (if (= 331 (car B)) 
         (list (cdr B)) 
       ) 
     ) 
          ) 
       ) 
       (entget a) 
      ) 
      ) 
    ) 
    (if (and (wcmatch (cdr (assoc 0 (setq a (entget a)))) 
        "TEXT,MTEXT,ATTRIB" 
      ) 
      (setq a (cdr (assoc 360 a))) 
      (setq a (dictsearch a "ACAD_FIELD")) 
      (setq a (dictsearch (cdr (assoc -1 a)) "TEXT")) 
      (setq a (cdr (assoc 360 a))) 
 ) 
      (__getfieldobjects a) 
    ) 
  ) 
  (defun _selectif (a b / c d) 
    (setq b (eval B)) 
    (while 
      (progn (setvar 'ERRNO 0) 
      (setq c (car (nentsel a))) 
      (cond ((= 7 (getvar 'ERRNO)) (princ "\nMissed, try again.")) 
     ((eq 'ENAME (type c)) 
      (if (not (setq d (b c))) 
        (princ "\nInvalid Object.") 
      ) 
     ) 
      ) 
      ) 
    ) 
    (if c 
      (cons c d) 
    ) 
  ) 
  (if (setq a 
      (mapcar (function 
         (lambda (a) 
    (vla-getboundingbox (vlax-ename->vla-object a) 'b 'c) 
    (setq b (vlax-safearray->list B) 
          c (vlax-safearray->list c) 
    ) 
    (list (_corners->list b c) (_midpoint b c)) 
         ) 
       ) 
       (_selectif "\nSelect Field: " '_getfieldobjects) 
      ) 
      ) 
    (progn 
      (princ "\nPress any key to Exit...") 
      (while (= 5 (car (setq b (grread t 9)))) 
 (redraw) 
 (_outline (setq c (cadar a) 
   d (_offsetoutside (caar a) (/ (getvar 'VIEWSIZE) 50.)) 
    ) 
    nil 
    nil 
    nil 
    3 
 ) 
 (foreach e (cdr a) 
   (_outline (_offsetoutside (car e) (/ (getvar 'VIEWSIZE) 50.)) 
      (cadr e) 
      d 
      c 
      1 
   ) 
 ) 
      ) 
    ) 
  ) 
  (redraw) 
  (princ) 
)

/db_自贡黄明儒_ · 发表于 2013-8-22 08:16:54

有点深呢，带点中国字吧，只有外文头大着呢！

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

[他山之石] Display Field Objects

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

评分

相关帖子