;;
;;
(defun C:TH()
;;
(setq ent1 (car (entsel "\nPick the Tree Level:"))); single pick
(setq ent4 (car (entsel "\nPick the Height Level:"))); single pick
(if ent1
(progn
(setq elist1 (entget ent1)); get a List of that entity
(setq atr1 (entnext ent1)); get 1st attribute entity
(setq en1 (entget atr1)); get a List of attribute entity
(setq val1 (cdr (assoc 1 en1))); get the attrib's value
(setq num1 (atof val1)); make a number of val
(if ent4
(progn
(setq elist4 (entget ent4)); get a List of that entity
(setq atr4 (entnext ent4)); get 1st attribute entity
(setq en4 (entget atr4)); get a List of attribute entity
(setq val4 (cdr (assoc 1 en4))); get the attrib's value
(setq num4 (atof val4)); make a number of val
(prompt (strcat "\nTREE LEVEL=" val1)); display on Command Line
(prompt (strcat "\nHEIGHT LEVEL=" val4)); display on Command Line
(SETVAR "cmdecho" 0)
(COMMAND "units" "" 2 "" "" "" "")
(setq HT (rtos (- num4 num1)))
(COMMAND "units" "" 3 "" "" "" "")
(SETVAR "cmdecho" 1)
(prompt (strcat "\nTREE HEIGHT=" HT)); display on Command Line
); progn
); if
(SETQ DFLT 0)
(SETQ TXTHG (GETVAR "textsize"))
(PRINC "\nText Height: <")
(PRIN1 TXTHG)
(PRINC ">: ")
(SETQ THGT (GETDIST))
(IF (= THGT nil)
(SETQ THGT TXTHG)
)
;(SETQ ANNOT (GETSTRING "\nAnnotation: "))
(SETQ HT1 (STRCAT "H: " HT))
(SETQ HT2 (STRCASE HT1))
;;(SETQ PTXT (GETPOINT "\nLocate Text: "))
(setq old_layer (getvar "clayer")); Get current Layer
(SETVAR "cmdecho" 0)
(setq PTXT (getvar "viewctr"))
(COMMAND "layer" "se" "tree text" "")
;(COMMAND "text" PTXT THGT "<<0" HT2)
;(command "move" "last" "" PTXT pause)
(setq CLASHING "CLASHING_LEVELS")
(if (not (tblsearch "layer" CLASHING))
(command "_layer" "M" CLASHING ""); Make the Layer, and set it current
); if
(command "_change" ent4 "" "_P" "_LA" CLASHING "")
(command "_layer" "S" old_layer ""); reset Layer
(SETVAR "cmdecho" 1)
(princ)
))); function LEV2HT
;; Room Number Update by CAB 03/21/2005
;; Update selected blocks with attribute "ROOM#"
;; with user entered room number
;; NOTE: Very little error checking
;;
;; Modified a subroutine by Jeff Mishler 1/11/05
;;
(defun c:rm#update (/ rm# attname ss count blk atts2 att2 att1 bc)
(vl-load-com)
(setq rm# (getstring t "\nEnter new room number: ")
attname "RM#" ; uppercase only
bc 0) ; block counter
(prompt "\n*** Select blocks to change room number. ***")
;; get only blocks with attributes
(if (and rm#
(not (eq rm# ""))
(setq ss (ssget (list '(0 . "INSERT") '(66 . 1))))
)
(progn
(setq count -1)
(while (< (setq count (1+ count)) (sslength ss))
(setq blk (vlax-ename->vla-object (ssname ss count))
atts2 (vlax-invoke blk "getattributes")
)
(foreach att2 atts2
(if (= attname (vla-get-tagstring att2))
(progn
(vla-put-textstring att2 rm#)
(vla-update att2)
(vla-update blk)
(setq bc (1+ bc))
)
)
)
)
(prompt (strcat "\n-=< " (itoa bc) " blocked updated >=-"))
) ; progn
(prompt "\n--- No blocks Updated ---")
) ; endif
(princ)
) ; defun
(prompt "\nRoom Number Update Loaded, Enter Rm#Update to run.")
(princ)
;; block = Attributed Block Entity Name [ENAME]
;; tag = Tag of Attribute to set to value [STR]
;; value = Value to which tag is set [STR]
(defun SetAttribValue ( block tag value / el )
(if (= 1 (cdr (assoc 66 (entget block))))
(while
(not
(eq "SEQEND"
(cdr
(assoc 0
(setq el
(entget
(setq block (entnext block))
)
)
)
)
)
)
(if (eq tag (cdr (assoc 2 el)))
(entupd
(cdr
(assoc -1
(entmod
(subst
(cons 1 value) (assoc 1 el) el
)
)
)
)
)
)
)
)
)
;; Example
(defun c:test ( / en tg vl )
(if (and (setq en (car (entsel "\nSelect Block: ")))
(eq "INSERT" (cdr (assoc 0 (entget en))))
(setq tg (getstring "\nSpecify Tag to Update: "))
(setq vl (getstring t "\nSpecify New Value: "))
)
(SetAttribValue en (strcase tg) vl)
)
(princ)
)
oh yeah, I reckon I can do something with that.
Cheers CAB!
P
yep got it working! brilliant stuff.
I would like to have the option to select the block again. ie: (if (and (setq en (car (entsel "\nSelect Block: ")))
but only if the block originally picked is not a 'PT2' block.
(princ "\nSelect INSERTs To Update....")
(and (setq i -1 ss (ssget '((0 . "INSERT")(66 . 1))))
(while (setq en (ssname ss (setq i (1+ i))))
(setq an (entnext en)
ad (entget an)
ch nil)
(while (= "ATTRIB" (cdr (assoc 0 ad)))
(and (= (strcase (cdr (assoc 2 ad))) "HEIGHT")
(setq ch T)
(entmod (subst (cons 1 ht1) (assoc 1 ad) ad)))
(setq an (entnext an)
ad (entget an)))
(if ch (entupd en))))
Sorry Lee.
I had a silly monent and thought your code was posted by CAB.
Your code has done the trick!
(defun c:test ( / en )
(while
(progn
(if (setq en (car (entsel "\nSelect Block: ")))
(if (and (eq "INSERT" (cdr (assoc 0 (entget en))))
(= 1 (cdr (assoc 66 (entget en))))
(eq "PT2" (strcase (cdr (assoc 2 (entget en)))))
)
(SetAttribValue en
(strcase (getstring "\nSpecify Tag: "))
(getstring t "\nSpecify New Value: ")
)
(princ "\n** Please Select a PT2 Block! **")
)
)
)
)
(princ)
)
Perhaps this subfunction will help you along the way - using Vanilla:Code: [Select];; block = Attributed Block Entity Name [ENAME]
;; tag = Tag of Attribute to set to value [STR]
;; value = Value to which tag is set [STR]
(defun SetAttribValue ( block tag value / el )
(if (= 1 (cdr (assoc 66 (entget block))))
(while
(not
(eq "SEQEND"
(cdr
(assoc 0
(setq el
(entget
(setq block (entnext block))
)
)
)
)
)
)
(if (eq tag (cdr (assoc 2 el)))
(entupd
(cdr
(assoc -1
(entmod
(subst
(cons 1 value) (assoc 1 el) el
)
)
)
)
)
)
)
)
)
;; Example
(defun c:test ( / en tg vl )
(if (and (setq en (car (entsel "\nSelect Block: ")))
(eq "INSERT" (cdr (assoc 0 (entget en))))
(setq tg (getstring "\nSpecify Tag to Update: "))
(setq vl (getstring t "\nSpecify New Value: "))
)
(SetAttribValue en (strcase tg) vl)
)
(princ)
)
I have also included an example of how to call the subfunction.
I would like to not have to select the block, but to indicate it programmatically. Have not had much success in that regard.
I would like to not have to select the block, but to indicate it programmatically. Have not had much success in that regard.
Bruce
(defun update_Xrecord ( DATA_VARS DXF_VAL MOD_VAL / xRecVar)
(setq xRecVar (get-or-make-Xrecord DATA_VARS))
(entmod (subst (cons DXF_VAL MOD_VAL)(assoc DXF_VAL xRecVar) xRecVar))
)
(update_Xrecord "LDATA_VARS" 410 "Update test successful !")
(setq DATA_VARS "LDATA_VARS")
Well the entmod function was working erratically, seemed to be appending to the end of the xrecord instead of modifying it. So I ended up doing the following;
1.- Create list of the existing xrecord, in a Sub-Dictionary within the NOD.
2.- Substitute values in the list for new values based on their DXF Group Codes.
3.- Delete the original Xrecord.
4.- Create a New Xrecord based on the Substituted List.
Thanks CAB for the advice to go this route, it will definitely make it difficult for the Users to mess up the data saved withing the Drawing.. 8-)
(setq Values (subst (cons DXF_VAL MOD_VAL)(assoc DXF_VAL xRecFile)xRecFile))
I have been experimenting and researching how to call say the 3rd instance of group code 300.
Any thoughts on how to perform the "subst" function on the 3rd instance of the group code.
(defun GC_Dict ( dictname / adict)
(if (not (setq adict (dictsearch (namedobjdict) dictname)))
(progn
(setq adict (entmakex '((0 . "DICTIONARY")(100 . "AcDbDictionary"))))
(if adict (setq adict (dictadd (namedobjdict) dictname adict)))
)
(setq adict (cdr (assoc -1 adict)))
)
);defun
(GC_Dict "SADATA_DICT") Example Calling Line
(defun GM_Xrecord ( DATA_VARS / adict anXrec)
(cond
((setq adict (GC_Dict "SADATA_DICT"))
(cond
((not (setq anXrec (dictsearch adict DATA_VARS)))
(setq anXrec (entmakex values))
(if anXrec (setq anXrec (dictadd adict DATA_VARS anXrec)))
)
(setq anXrec
(cdr (assoc -1 (dictsearch adict DATA_VARS)))
);setq
);cond
);setq
);cond
);defun
(GM_Xrecord "LDATA_VARS") Example Calling Line ;
(setq x 11.23
y 23.43
z 43.23
test 34.54
test2 "This is line 5")
(setq Values (list(cons 0 "XRECORD") ; used for storing integers in "XRECORDS" can also use 270-289
(cons 100 "AcDbXrecord")
(cons 70 2 )
(cons 71 3 )
(cons 72 4 )
(cons 73 5 )
(cons 74 6 )
(cons 75 7 )
(cons 76 8 )
(cons 12 (list x y))
(cons 11 (list x y z))
)
);setq
(setq Values (list(cons 0 "XRECORD") ; used for storing reals in "XRECORDS" can also use 140-149
(cons 100 "AcDbXrecord")
(cons 40 2.1234 )
(cons 41 3.4568 )
(cons 42 4.3254 )
(cons 43 5.3214 )
(cons 44 6.3256 )
(cons 45 test )
(cons 46 8.6384 )
(cons 47 9.2458 )
(cons 48 10.7854 )
)
);setq
(setq Values (list(cons 0 "XRECORD") ; used for storing strings in "XRECORDS" can also use 301-309
(cons 100 "AcDbXrecord")
(cons 300 "This is line 1" )
(cons 300 "This is line 2" )
(cons 300 "This is line 10" )
(cons 300 "This is line 3" )
(cons 300 "This is line 4" )
(cons 300 test2 )
(cons 300 "This is line 6" )
(cons 300 "This is line 7" )
(cons 300 "This is line 8" )
(cons 300 "This is line 9" )
)
);setq
(defun GetVar_Xrecord ( DATA_VARS DXF_VAL LnmBr / xRecFile vars )
(defun LM:mAssoc ( DXF_VAL xRecFile / item )
(if (setq item (assoc DXF_VAL xRecFile))
(cons (cdr item) (LM:mAssoc DXF_VAL (cdr (member item xRecFile))))
)
);defun
(setq vars (GM_Xrecord DATA_VARS))
(cond (vars
(setq xRecFile (entget vars))
(cdr (cons DXF_VAL(nth LnmBr (LM:mAssoc DXF_VAL xRecFile))))
)
(T nil)
)
);defun
(setq VARNAME (GetVar_Xrecord "LDATA_VARS" 300 2 )) Calling Line
(defun Update_Xrecord (DATA_VARS DXF_VAL MOD_VAL LnmBr / xRecFile Values SAdict)
(defun LM:mAssoc ( DXF_VAL xRecFile / item )
(if (setq item (assoc DXF_VAL xRecFile))
(cons (cdr item) (LM:mAssoc DXF_VAL (cdr (member item xRecFile))))
)
);defun
(setq SAdict (dictsearch (namedobjdict) "SADATA_DICT")
xRecFile (dictsearch (cdr (assoc -1 SAdict)) DATA_VARS)
)
(setq values (subst (cons DXF_VAL MOD_VAL) (cons DXF_VAL(nth LnmBr (LM:mAssoc DXF_VAL xRecFile))) xRecFile))
(entdel (cdr (assoc -1 xRecFile)))
(GM_Xrecord DATA_VARS)
);defun
(Update_Xrecord "LDATA_VARS" 300 "Update test successful again 3 !" 4) Example Calling line
(defun xRecord_Exist ( DATA_VARS / SAdict xRecFile )
(setq SAdict (dictsearch (namedobjdict) "SADATA_DICT")
xRecFile (dictsearch (cdr (assoc -1 SAdict)) DATA_VARS)
)
(princ xRecFile)
)
(xRecord_Exist "LDATA_VARS") ExampleCalling line