TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: kraz on June 11, 2009, 01:32:52 AM
-
hi~
I want to control Rollover Func Using Lisp to display ObjectData Values...
Who can Help me....!
-
Was doing a search on object data and since this was never answered, thought i'd share.
Only functions on autocad map products with entities containing object data.
(defun c:rod (/ )(c:readobjectdata))
(defun c:readobjectdata (/ count ename *error* fieldnames fieldstring input strcatlst tablelist textename usercmdecho viewsize)
(defun *error* ( msg )
(princ (strcat "\n<" msg ">\n"))
(progn
(and TextENAME (entdel TextENAME))
(vl-cmdf "ucs" "p")
(setvar "cmdecho" usercmdecho)
);progn
(princ)
);defun
(setq usercmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(vl-cmdf "ucs" "w")
(while (and (setq Input (grread T 4 2)) (= (car Input) 5))
(if TextENAME
(progn (entdel TextENAME) (setq TextENAME nil))
);if
(if
(and (setq ENAME (car (nentselp (cadr Input))))
(not (eq TextENAME ENAME))
);and
(progn
(setq viewsize (getvar "VIEWSIZE"))
(setq tablelist (ade_odgettables ename))
(setq count 0)
(repeat (length tablelist)
(foreach x (cdr (assoc "Columns" (ade_odtabledefn (nth count tablelist))))
(if (not (member (cdr (assoc "ColName" x)) fieldnames))
(setq fieldnames (cons (cdr (assoc "ColName" x)) fieldnames))
)
)
(setq count (1+ count))
)
(if fieldnames (setq fieldnames (acad_strlsort fieldnames)))
(setq strcatlst
(apply 'strcat
(mapcar
(function
(lambda (x)
(strcat x " : "
(If (/= (type (setq fieldstring (ade_odgetfield ename (ade_odgettables ename) x 0))) 'STR)
(rtos fieldstring 2 2)
fieldstring
)
"\n")
)
)
fieldnames
)
)
)
(setq TextENAME
(entmakex
(list
(cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 1
(strcat "{\\fArial;"
strcatlst
"}"
);strcat
);cons 1
(cons 10
(polar (cadr Input) 0 (/ ViewSize 50.0))
)
(cons 40 (/ ViewSize 75.0));
(cons 50 (- 0 (getvar "VIEWTWIST")))
(cons 62 250)
(cons 71 1)
(cons 72 5)
(cons 90 1)
(cons 63 255)
(cons 45 1.2)
);list
);entmakex
);setq
);progn
);if
);while
(and TextENAME (entdel TextENAME))
(vl-cmdf "ucs" "p")
(setvar "cmdecho" usercmdecho)
(princ)
);defun
-
Similar perhaps?
http://www.theswamp.org/index.php?topic=33078.0 (http://www.theswamp.org/index.php?topic=33078.0)
http://www.theswamp.org/index.php?topic=28710.0 (http://www.theswamp.org/index.php?topic=28710.0)
-
Very similar. Actually used this as the base code though http://www.theswamp.org/index.php?topic=26078.0 (http://www.theswamp.org/index.php?topic=26078.0)
-
One more... http://www.theswamp.org/index.php?topic=30660.0
-
wow....after 1 year...hehe
yes...mtext is the correct.
since i posted my question, i got the answer that mtext & grread.
thanks for u'r answer.
god bless u~
-
No problem KRAZ. I didn't think the grread mtext part was a problem.
I just haven't seen much code dealing with object data.
Do you mind sharing the code you used to access it?
-
hmm...it's not good but working.....
another one's is better than me....
plz use this code for looking around .... :oops:
p.s: this code is working on acad map version
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun display_attr( / text $error$ grr en att lay col tname table_def
flist fv_string f flist v en_bak)
(defun get_od_val(sn fld_name / tblname get_fld)
(if (ade_odgettables sn)
(progn
(setq tblname (car (ade_odgettables sn)))
(setq get_fld (ade_odgetfield sn tblname fld_name 0))
)
(setq get_fld nil)
)
get_fld
)
(setq Text (vlax-ename->vla-object
(entmakex (list (cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 8 (getvar "clayer"))
(cons 62 65)
(cons 90 1)
(cons 63 41)
(cons 45 1.3)
(cons 40 (* (getvar "viewsize") 0.1))
(cons 10 (trans (cadr (grread T 15 0)) 1 0))
) ;_ list
) ;_ entmakex
) ;_ vlax-ename->vla-object
) ;_ setq
(setq $error$ (lambda (x) (and Text (vl-catch-all-apply 'vla-delete (list Text)))))
(while (and (setq grr (grread T 4 2)) (= (car grr) 5))
(if (and (setq en (car (nentselp (cadr grr)))) (/= en (vlax-vla-object->ename Text)))
(progn
(vla-put-insertionpoint Text (vlax-3d-point (polar (trans (cadr grr) 1 0) (* pi 1.75) (* (getvar "viewsize") 0.02))) ) ;_ vla-put-insertionpoint
(vla-put-height Text (* (getvar "viewsize") 0.013))
;get att
(setq lay (cdr (assoc 8 (entget en)))
col (cdr (assoc 62 (entget en)))
)
(if (null col) (setq col 256))
(cond
((eq col 1) (setq col "RED"))
((eq col 2) (setq col "YELLOW"))
((eq col 3) (setq col "GREEN"))
((eq col 4) (setq col "CYAN"))
((eq col 5) (setq col "BLUE"))
((eq col 6) (setq col "MAGENTA"))
((eq col 7) (setq col "WHITE"))
((eq col 8) (setq col "GRAY"))
((eq col 255) (setq col "BYBLOCK"))
((eq col 256) (setq col "BYLAYER"))
(t (setq col (itoa col)))
);cond
(if (ade_odgettables en)
(progn
(setq tname (car (ade_odgettables en)))
(setq table_def (ade_odtabledefn tname))
(setq flist (mapcar 'cdar (cdr (assoc "Columns" table_def))))
(setq fv_string (strcat "\n### ObjectTable ###\nTable: " tname))
(foreach f flist
(setq v (get_od_val en f))
(if (numberp v)
(progn
(if (int-p v)
(setq v (itoa v))
(setq v (rtos v 2 6))
)
)
)
(setq fv_string (strcat fv_string "\n" f ": " v))
)
(setq att (strcat "Layer: " lay "\nColor: " col fv_string))
(vla-put-textstring Text att)
)
(progn
(setq att (strcat "Layer: " lay "\nColor: " col))
)
);if
;get att end
)
(progn
(setq att "" en nil en_bak nil)
(vla-put-textstring Text att)
)
);if
);while
(vla-delete text)
($error$ nil)
)
No problem KRAZ. I didn't think the grread mtext part was a problem.
I just haven't seen much code dealing with object data.
Do you mind sharing the code you used to access it?
[edit:kdub:codeformatted]
-
Code Formatting (http://www.theswamp.org/index.php?topic=4429.0)