;;;Chapter 23. Associating information to Graphic Objects.
(defun ent-read-attributes (ename / ent lst txt)
(setq ent (entget ename))
(if
(and (equal (cdr (assoc 0 ent)) "INSERT")
(> (cdr (assoc 66 ent)) 0))
(progn (setq ent (entget (entnext ename)))
(while (not (= (cdr (assoc 0 ent)) "SEQEND"))
(foreach datum ent
(if (or (= (car datum) 1) (= (car datum) 3))
(setq txt (cons (cdr datum) txt))))
(setq lst (cons
(cons (cdr (assoc 2 ent))
(replace
""
"\\P"
(apply 'strcat (reverse txt))))
lst)
ent (entget (entnext (cdr (assoc -1 ent))))))))
(reverse lst))
;;;Listing 23.1. Function that reads a block insert's variable attributes.
(defun prp-read-attributes (ename / ent lst txt)
(setq ent (entget ename))
(if
(and (equal (cdr (assoc 0 ent)) "INSERT")
(> (cdr (assoc 66 ent)) 0))
(progn
(setq ent (entnext ename))
(while (not (= (cdr (assoc 0 (entget ent))) "SEQEND"))
(setq val (getpropertyvalue ent "Value")
lst (cons
(cons (getpropertyvalue ent "Tag")
(if (vl-string-search "\\P" val)
(replace " " "\\P" val)
val))
lst)
ent (entnext ent)))))
(reverse lst))
;;;Listing 23.2 Extracting Attributes using non-Com properties.
(defun ax-extract-attrib (block constant / attributes lst)
(setq attributes (vlax-variant-value
(if constant
(vla-getconstantattributes block)
(vla-getattributes block))))
(if (>= (vlax-safearray-get-u-bound attributes 1) 0)
(foreach attrib (vlax-safearray->list attributes)
(setq lst (cons
(cons (vlax-get-property attrib "TagString")
(if
(= (vla-get-MTextAttribute attrib)
:vlax-true)
(replace
""
"\\P"
(vlax-get-property attrib "TextString"))
(vlax-get-property attrib "TextString")))
lst))))
lst)
;;;Listing 23.3. Standard function to extract variable or constant attribute values.
(defun ax-read-attributes (ename / block result lst)
(setq block (vlax-ename->vla-object ename))
(setq result (vl-catch-all-apply
'vla-get-HasAttributes
(list block)))
(if (eq result :vlax-true)
(append (reverse (ax-extract-attrib block t))
(reverse (ax-extract-attrib block nil)))))
;;;Listing 23.4. Processing a block to extract a list with all its attributes.
(defun ent-xdata (ename appname lis-id lis-val / data lst obj)
(if (not (tblsearch "appid" appname))
(regapp appname))
(setq data (list
-3
(cons appname
(foreach term (mapcar 'strcat lis-id lis-val)
(setq lst (append lst
(list (cons 1000 term))))))))
(setq obj (append (entget ename) (list data)))
(entmod obj))
;;;Listing 23.5. XDATA assignment.
(defun ent-read-xdata (ename appname id as-string / val)
(setq id (strcat id "=*")
val (cdar
(vl-remove-if-not
'(lambda (x) (wcmatch (cdr x) id))
(cdadr (assoc -3 (entget ename (list appname)))))))
(if val
(progn (setq val (vl-string-left-trim id val))
(if as-string
val
(read val)))))
;;;Listing 23.6. Reading XDATA.
(defun dict-list ()
(mapcar 'cdr
(vl-remove-if-not
'(lambda (x) (= (car x) 3))
(entget (namedobjdict)))))
;;;Listing 23.7. Obtaining a list of all the dictionaries.
(defun data-input (/ ent name lst)
(while
(and (setq ent (car (entsel "\nSelect entity to name: ")))
(setq name (getstring t "\nSpecify name: "))
(not (= name "")))
(setq lst (cons (cons (cdr (assoc 5 (entget ent))) name)
lst)))
lst)
;;;Listing 23.8. Data entry function.
(defun make-dict (name)
(if (not (member name (dict-list)))
(dictadd (namedobjdict)
name
(entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary"))))
(cdr (assoc -1 (dictsearch (namedobjdict) name)))))
;;;Listing 23.9. Function that creates a dictionary, or retrieves its ENAME in case it already exists.
(defun new-records (dict-ent data-list / xrec)
(foreach datum data-list
(if (dictsearch dict-ent (car datum))
(entdel (dictremove dict-ent (car datum))))
(if
(setq xrec (entmakex
(list '(0 . "XRECORD")
'(100 . "AcDbXrecord")
(cons 1 (cdr datum)))))
(dictadd dict-ent (car datum) xrec)
(prompt "\Error adding record"))))
;;;Listing 23.10. Adding new entries to the dictionary.
(defun C:TOPONYMS (/ data dict)
(cond
((setq dict (dictsearch (namedobjdict) "TOPONYMS"))
(setq dict (cdr (assoc -1 dict))))
((setq dict (make-dict "TOPONYMS")))
(t
(prompt "\nError creating the TOPONYMS dictionary")))
(if (and dict (setq data (data-input)))
(new-records dict data)
(alert "Application error"))
(princ))
;;;Listing 23.11. Main function C:TOPONYMS.
(defun C:IDENTIFY (/ dict ent place)
(if
(and (setq dict (dictsearch (namedobjdict) "TOPONYMS"))
(setq dict (cdr (assoc -1 dict))))
(while (setq ent (car (entsel "\nSelect entity to identify: ")))
(if (setq place (dictsearch dict (cdr (assoc 5 (entget ent)))))
(alert
(strcat "The selected entity represents\n"
(cdr (assoc 1 place))))
(alert "The entity does not have\na toponymic assigned.")))))
;;;Listing 23.12. Function that queries the linked data.
(defun C:DELETE-PLACE (/ dict ent)
(if
(and (setq dict (dictsearch (namedobjdict) "TOPONYMS"))
(setq dict (cdr (assoc -1 dict))))
(setq ent (car
(entsel
"\nSelect the entity whose name is to be deleted: "))))
(setq ent (cdr (assoc 5 (entget ent))))
(if (dictsearch dict ent)
(entdel (dictremove dict ent))
(alert "The entity does not have\na place assigned.")))
;;;Listado 23.12a. Function that deletes an associated toponym.
(defun list->ldata (dict lst)
(foreach sublist lst
(if (listp sublist)
(vlax-ldata-put
dict
(vl-princ-to-string (car sublist))
(cdr sublist)))))
;;;Listing 23.13. LIST->LDATA function.
(defun list->ldata (dict lst)
(foreach sublist lst
(if (and (listp sublist) (vlax-ldata-test (cdr sublist)))
(vlax-ldata-put
dict
(vl-princ-to-string (car sublist))
(cdr sublist)))))
;;;Listing 23.14. Function LIST->LDATA including VLAX-LDATA-TEST.
(defun associate (ent-main ent-assoc key)
(vlax-ldata-put ent-main key ent-assoc))
;;;Listing 23.15. Function to associate entities using LDATA.
(defun locate-ADO-CAO (/ dir lcid CAOdir ADOdir)
(setq dir (getenv "COMMONPROGRAMFILES")
ADOdir (findfile (strcat dir "\\system\\ado\\msado15.dll"))
lcid (vla-get-LocaleID (vlax-get-acad-object))
rel (if (> (atoi (getvar "ACADVER")) 19)
"20"
"16")
CAOdir (findfile
(strcat
dir
"\\AUTODESK SHARED\\"
(cond
((= lcid 1028) (strcat "cao" rel "cht.tlb"))
((= lcid 1029) (strcat "cao" rel "csy.tlb"))
((= lcid 1031) (strcat "cao" rel "deu.tlb"))
((= lcid 1034) (strcat "cao" rel "esp.tlb"))
((= lcid 1036) (strcat "cao" rel "fra.tlb"))
((= lcid 1038) (strcat "cao" rel "hun.tlb"))
((= lcid 1040) (strcat "cao" rel "ita.tlb"))
((= lcid 1041) (strcat "cao" rel "jpn.tlb"))
((= lcid 1042) (strcat "cao" rel "kor.tlb"))
((= lcid 1046) (strcat "cao" rel "ptb.tlb"))
((= lcid 1049) (strcat "cao" rel "rus.tlb"))
((= lcid 2052) (strcat "cao" rel "chs.tlb"))
(t (strcat "cao" rel "enu.tlb"))))))
(list ADOdir CAOdir))
;;;Listing 23.16. Function that searches the libraries paths. Release 2015 - 2018
(defun import-ADO-CAO (/ libs)
(vl-load-com)
(setq libs (locate-ADO-CAO))
(if (car libs)
(cond
((vl-member-if
'(lambda (x) (wcmatch x "ADOM-*"))
(atoms-family 1))
t)
(t
(vlax-import-type-library
:tlb-filename
(car libs)
:methods-prefix
"adoM-"
:properties-prefix
"adoP-"
:constants-prefix
"adoC-")))
(prompt "\nERROR: ADO library not found"))
(if (last libs)
(cond
((vl-member-if
'(lambda (x) (wcmatch x "CAOM-*"))
(atoms-family 1))
t)
(t
(vlax-import-type-library
:tlb-filename
(last libs)
:methods-prefix
"caoM-"
:properties-prefix
"caoP-"
:constants-prefix
"caoC-")))
(prompt "\nERROR: CAO library not found.")))
;;;Listing 23.16. Function that imports component libraries.
No comments:
Post a Comment