Three programs using EXTENDED ENTITY DATA

[aaronic_abacus]

Three programs using EXTENDED ENTITY DATA.
Using WED(write extended entity data), RED(read entity data), and CED(copy entity data),
allows a nested block name into an entity.

(DEFUN C:WED (/ CEV ENT ENTL AENT AEBN ND ED EDS EDS2 TDT NED LP CT DN LOP AR LP2 BSN LP3 LP4 BP LP5 BSET BNL BNA)
  (PROMPT "\n*WRITE ENTITIY DATA*")
  (SETQ AR (GETVAR "ATTREQ"))
  (SETVAR "ATTREQ" 0)
;(SETQ CEV (GETVAR "EXPERT"))
;(SETVAR "EXPERT" 2)
  (SETQ LP2 1)
  (WHILE LP2
    (INITGET "F N")
    (SETQ BNS (ENTSEL "\nFile name/Nest block/select block: "))
    (IF	(= BNS "F")
      (PROGN
	(PROMPT "\nSelect block to associate with host : ")
	(SETQ DN (GETFILED "SELECT ASSOCIATED BLOCK" "" "DWG" 8))
	(IF (/= DN NIL)
	  (SETQ LP2 NIL)
	  (PROMPT "NO FILE SELECTED.")
	)
      )
    ) ;END PROGN/IF 
    (IF	(= BNS "N")
      (PROGN
	(SETQ LP3 1)
	(WHILE LP3
	  (SETQ DN (GETFILED "CREATE DRAWING" "" "DWG" 1))
	  (IF (/= DN NIL)
	    (PROGN
	      (SETQ LP4 1)
	      (WHILE LP4
		(PROMPT "\npick base point: ")
		(SETQ BP (GETPOINT))
		(IF (/= BP NIL)
		  (SETQ LP4 NIL)
		  (PROMPT "NO POINT PICKED")
		)
	      ) ;END LP4 
	      (SETQ LP5 1)
	      (WHILE LP5
		(PROMPT "\nchoose objects to nest in block ")
		(SETQ BSET (SSGET))
		(IF (/= BSET NIL)
		  (PROGN
		    (COMMAND "WBLOCK" DN "" BP BSET "")
		    (SETQ LP5 NIL)
		  ) ;END PROGN
		  (PROMPT "NO OBJECTS SELECTED ")
		)
	      ) ;END IF BSET/LP5
	      (PROGN
		(SETQ LP3 NIL)
		(SETQ LP2 NIL)
	      ) ;END PROGN
	    ) ;END PROGN DN
	    (PROGN
	      (PROMPT "NO FILE NAME ENTERED ")
	      (SETQ LP3 NIL)
	    ) ;END PROGN
	  )
	)
      )
    ) ;END IF LP3/DN PROGN BSN/ IF BSN
    (IF	(AND (/= BNS "N") (/= BNS "F"))
      (PROGN
	(SETQ BN (CAR BNS))
	(IF (/= BN NIL)
	  (PROGN
	    (SETQ BNL (ENTGET BN))
	    (SETQ BNA (CDR (ASSOC 0 BNL)))
	    (IF	(= BNA "INSERT")
	      (PROGN
		(SETQ DN (CDR (ASSOC 2 BNL)))
		(SETQ LP2 NIL)
	      ) ;END PROGN
	      (PROMPT "OBJECT NO A BLOCK ")
	    )
	  ) ;END IF INSERT/ PROGN BN
	  (PROMPT "NO OBJECT SELECTED ")
	) ;END IF BN 
      )
    ) ; END PROGN/IF BNS 
  ) ;END LP2
  (IF (= DN NIL)
    (EXIT)
  )
  (COMMAND "INSERT" DN "0,0" "" "" "")
  (SETQ AENT (ENTLAST))
  (SETQ AENTL (ENTGET AENT))
  (SETQ AEBN (CDR (ASSOC 2 AENTL)))
  (COMMAND "ERASE" AENT "")
  (SETQ LOP 1)
  (WHILE LOP
    (PROMPT "\nSelect host entity(s) ")
    (SETQ ENTS (SSGET))
    (IF	(/= ENTS NIL)
      (SETQ LOP NIL)
      (PROMPT "NO ENTITIY(S) SELECTED ")
    )
  ) ;END LOP
  (SETQ ENTSL (SSLENGTH ENTS))
  (SETQ CT (- ENTSL 1))
  (SETQ LP 1)
  (WHILE LP
    (SETQ ENT (SSNAME ENTS CT))
    (SETQ ENTL (ENTGET ENT))
    (SETQ ND (CONS 1000 AEBN))
    (SETQ ED '((-3 ("EDATA" (1000 . "SUB")))))
    (SETQ EDS (CADAR ED))
    (SETQ EDS2 (CAR ED))
    (SETQ TDT (CAR (CDAR (CDAR ED))))
    (SETQ NED (SUBST ND TDT EDS))
    (SETQ NED (SUBST NED EDS EDS2))
    (SETQ NED (SUBST NED EDS2 ED))
    (REGAPP "EDATA")
    (SETQ NED (APPEND ENTL NED))
    (ENTMOD NED)
    (REDRAW ENT)
    (SETQ CT (- CT 1))
    (IF	(< CT 0)
      (SETQ LP NIL)
    )
  ) ;END LP
  (SETVAR "ATTREQ" AR)
;(SETVAR "EXPERT" CEV)
  (PRINC)
) ;END WED

(DEFUN C:RED (/ ENT ENTL ENTPT AENT AEBN ND ED EDS EDS2 TDT NED)
  (PROMPT "\n*READ ENTITIY DATA*")
  (SETQ ENT (ENTSEL "\nSelect host entity : "))
  (SETQ ENTL (ENTGET (CAR ENT)))
  (SETQ ENTPT (CDR ENT))
  (SETQ EDATAL (ENTGET (CAR ENT) '("EDATA")))
  (SETQ EDBNS (ASSOC -3 EDATAL))
  (SETQ EDBN (CDR (CADAR (CDR EDBNS))))
  (COMMAND "INSERT" EDBN)
  (PRINC)
) ;END RED

(DEFUN C:CED (/ ENT ENTL ENTPT AENT ND ED EDS EDS2 TDT NED LOP ENTS ENTSL CT LP)
  (PROMPT "\n*COPY ENTITIY DATA*")
  (SETQ ENT (ENTSEL "\nSelect main host entity : "))
  (SETQ ENTL (ENTGET (CAR ENT)))
  (SETQ ENTPT (CDR ENT))
  (SETQ EDATAL (ENTGET (CAR ENT) '("EDATA")))
  (SETQ EDBNS (ASSOC -3 EDATAL))
  (SETQ EDBN (CDR (CADAR (CDR EDBNS))))
  (SETQ LOP 1)
  (WHILE LOP
    (PROMPT "\nSelect new host entity(s) ")
    (SETQ ENTS (SSGET))
    (IF	(/= ENTS NIL)
      (SETQ LOP NIL)
      (PROMPT "NO ENTITIY(S) SELECTED ")
    )
  ) ;END LOP
  (SETQ ENTSL (SSLENGTH ENTS))
  (SETQ CT (- ENTSL 1))
  (SETQ LP 1)
  (WHILE LP
    (SETQ ENT (SSNAME ENTS CT))
    (SETQ ENTL (ENTGET ENT))
    (SETQ ND (CONS 1000 EDBN))
    (SETQ ED '((-3 ("EDATA" (1000 . "SUB")))))
    (SETQ EDS (CADAR ED))
    (SETQ EDS2 (CAR ED))
    (SETQ TDT (CAR (CDAR (CDAR ED))))
    (SETQ NED (SUBST ND TDT EDS))
    (SETQ NED (SUBST NED EDS EDS2))
    (SETQ NED (SUBST NED EDS2 ED))
    (REGAPP "EDATA")
    (SETQ NED (APPEND ENTL NED))
    (ENTMOD NED)
    (REDRAW ENT)
    (SETQ CT (- CT 1))
    (IF	(< CT 0)
      (SETQ LP NIL)
    )
  ) ;END LP
  (PRINC)
) ;END CED

[ Moderator Action = ON ] What are [ CODE ] tags... [ Moderator Action = OFF ]

[peter]

Here is a couple functions that manipulate extended data using activeX
The nice thing about them is you can get and retrieve a list of sublists.

Like

(setxdata (car (entsel)) (list (list "MyXdataApp" "Hello" 1 3.14)))

and

(getxdata (car (entsel)))

will return

'(("MyXdataApp" "Hello" 1 3.14))

plus any additional xdata on the object.

; Written By: Peter Jamtgaard P.E. copr 2003
; The setxadatalist function will add a list of sublists to an object as xdata.
; The first item in each sublist is a unique string application name
(defun SetXData (objSelection lstOfSubLists / DataItem lstData
                 intDataType lstOfSublistsDXFCodes lstOfSublistsValues 
                 safDXFCodes safDataValues)                
 (if debug (princ "\nSetXdata: "))
 (if (= (type objSelection) 'ENAME)
  (setq objSelection (vlax-ename->vla-object objSelection))
 )
 (foreach lstData lstOfSublists
  (setq lstOfSublistsDXFCodes (cons 1001 lstOfSublistsDXFCodes)
        lstOfSublistsValues   (cons (car lstData) lstOfSublistsValues))
  (RegApp (car lstData))
  (foreach DataItem (cdr lstData)
   (cond    ; Determine the data type and corrusponding DXF Code
    ((= (type DataItem) 'INT) 
     (if (> DataItem 100000)
      (setq intDataType  1071)                          ; Long    Data Type 
      (setq intDataType  1070)                          ; Integer Data Type
     )
    )                                                   
    ((= (type DataItem) 'REAL)(setq intDataType  1040)) ; Real Data Type
    ((= (type DataItem) 'STR) 
     (if (or (= DataItem "{")(= DataItem "}"))          ; String Data Type     
      (setq intDataType  1002)
      (setq intDataType  1000)
     )
    )
   )
   (setq lstOfSublistsDXFCodes (cons intDataType lstOfSublistsDXFCodes)
         lstOfSublistsValues   (cons DataItem    lstOfSublistsValues)
   )
  )
 )
 (setq safDXFCodes   (listToSafearray vlax-vbinteger
                      (reverse lstOfSublistsDXFCodes))                     
       safDataValues (listToSafeArray vlax-vbvariant
                      (reverse lstOfSublistsValues)))
 (errortrap '(vla-setXData objSelection safDXFCodes safDataValues)))

; Returns a list of sublists that include a application name as the first
; Item in every sublist and data for the remaining members

(defun C:GetXdata ()
 (getxdata (car (entsel "\nSelect object with Xdata: ")))
)

(defun GetXdata (objSelection / intCount lstAll lstSub safDXFValues safDXFValues)
;  (print strXdata)  (if DEBUG (print "GetXdata"))
 (if (= (type objSelection) 'ENAME)
  (setq objSelection (vlax-ename->vla-object objSelection))
 )
 (vla-getxdata objSelection "" 'safDXFCodes 'safDXFValues) 
 (if (and safDXFCodes
          safDXFValues
     )
  (progn
   (setq lstDXFCodes  (vlax-safearray->list safDXFCodes)  
         lstDXFValues (mapcar 'variant-value (vlax-safearray->list safDXFValues))  
         intCount 0
   )
   (foreach intDXFCode lstDXFCodes
    (if (= intDXFCode 1001)
     (if lstSub
      (setq lstAll (cons (reverse lstSub) lstAll)
            lstSub (list (nth intCount lstDXFValues))
      )
      (setq lstSub (list (nth intCount lstDXFValues)))  
     )
     (setq lstSub (cons (nth intCount lstDXFValues) lstSub))   
    )
    (setq intCount (1+ intCount))
   )
   (if lstSub (reverse (cons (reverse lstSub) lstAll)))
  )
 )
)