[编程交流] lisp嵌套块的帮助

;;local defun
;;helper method to group a list of items by their tags
(defun group-by-car (lst)
;;ensure that the list is not empty
(if lst
(cons
(vl-remove-if-not
;;this is a lambda function to compare the equality of the tags
(function (lambda (x)
(equal (car x) (caar lst) 0.00001)))
lst
)
;;recursive call to group a sublist
(group-by-car
(vl-remove-if
(function (lambda (x)
(equal (car x) (caar lst) 0.00001)))
lst))))
)
;;main program
;;define the main function, localize all variables.
(defun C:SUMTABLE (/ acsp att atts block_obj data en ent_list item
match_list pt sset tag tags tmp)
;;look for block
(if (not (tblsearch "block" "GKW_Totaal"))
(progn
;;if it is not found, alert user and exit program
(alert "Block "GKW_Totaal" does not exist. Exit program.")
(exit)(princ))
)
(setq acsp (vla-get-block ;;get the block representation of the layout
(vla-get-activelayout ;;get the current layout
(vla-get-activedocument ;;get the current drawing
(vlax-get-acad-object)))) ;;get AutoCAD application
)
;;create a list to match attribute tags
(setq match_list (list "GKW" "FLOW" "KPA"))
;;get a selection set of all blocks with attributes
(setq sset (ssget (list (cons 0 "INSERT") (cons 66 1)))
)
;;start to loop through selection set
(while (setq en (ssname sset 0))
;;add current entity to a list of entities
(setq ent_list (cons en ent_list))
;;get the first attribute from the entity
(setq att (entnext en))
;;start while loop through attributes in the block
(while (/= (cdr (assoc 0 (entget att))) "SEQEND")
;;if there is an attribute
(if (and att
;;AND its tag is in the list of tags to match
(member (setq tag (cdr (assoc 2 (entget att)))) match_list))
;;then get the value from the tag and place into a dotted pair list
(setq tags (cons (cons tag (cdr (assoc 1 (entget att)))) tags)))
;;get the next attribute
(setq att (entnext att)))
;;deletes an entity from the current selection set
(ssdel en sset)
)
;;loop through each pair of dotted pairs in the tags list
(foreach item (group-by-car tags)
;;if the tag is KPA...
(if (eq (caar item) "KPA")
;;get the maximum for KPA
(setq tmp (list (caar item)
(vl-princ-to-string (apply 'max (mapcar 'atof (mapcar 'cdr item))))))
;;otherwise, sum all other values together
(setq tmp (list (caar item)
(vl-princ-to-string (apply '+ (mapcar 'atof (mapcar 'cdr item))))))
)
;;NOTE: mapcar is used to apply a function to a list of items. The function is applied
;;to every item in the list. atof will turn a string into a real number
;;add the computed values to a list
(setq data (cons tmp data)
)
)
;;turn all values into strings, rtos is used to accomplish this
(setq data (mapcar (function (lambda(x)
(cons (car x)
(rtos (atoi (cadr x)) 2 0))))
data
)
)
;;prompt user for an insertion point
(setq pt (getpoint "\nSpecify insertion point of the block: ")
)
;;insert a block with a scale of 1 and rotation of 0
(setq block_obj (vlax-invoke acsp 'Insertblock pt "GKW_Totaal" 1 1 1 0))
;;get the attributes for the inserted block
(setq atts (vlax-invoke block_obj 'GetAttributes))
;;loop through the attributes in the inserted block
(foreach att atts
;;if the tag for the attribute is found...
(if (setq item (assoc (vla-get-tagstring att) data))
;;put the value into the attribute
(vla-put-textstring att (cdr item)))
)
;;silent exit
(princ)
)
;;inform the user how to start the program
(prompt "\n\t\t***\tType SUMTABLE to execute\t***")
(prin1)
;;load VL* functions
(vl-load-com)