Ok, I got your point. I added the possibility to revise the active selection. You'll still need to pick a point in the middle, but then the routine stops with highlighted blocks and you can add/remove some from the selection. Then the routine continues.
The second issue I can see is the wrong attributes assignment. I see that you modified and renamed the OBEM block. Good. But you need to maintain the order of attributes - or change the order in the code. See the command-line listing vs. code:
Command: _INSERT Enter block name or [?] <OBEM>: OBEM Specify insertion point or [Basepoint/Scale/Rotate]: _Scale Specify scale factor for XYZ axes <1>: 0.200000000000000 Specify insertion point or [Basepoint/Scale/Rotate]: _Rotate
Specify rotation angle <0.0000g>: 0 Specify insertion point or [Basepoint/Scale/Rotate]: _none
Enter attribute values
Number: 1 Average: 67.5 Area: 150 Volume: 45 N: 1
(command "_.INSERT" "OBEM" "_Scale" 0.2 "_Rotate" 0 "_none" pnt
idx
(rtos vol 2 2)
(rtos are 2 2)
(rtos avr 2 2)
num)
You can see that the order is upside-down! Fix that yourself either way.
(defun c:InsertVolumeBlock ( / *error* und atd atr :GetAttValByTag enl pnt ss i en val lst are avr vol ixd num )
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
(princ (strcat "\nError: " errmsg)))
(if und (command-s "_UNDO" "_Back"))
(if atd (setvar 'ATTDIA atd))
(if atr (setvar 'ATTREQ atr))
(princ))
(defun :GetAttValByTag (blk tag / val)
(while (= "ATTRIB" (cdr (assoc 0 (setq ed (entget (setq blk (entnext blk)))))))
(if (= (strcase (cdr (assoc 2 ed))) tag)
(setq val (read (cdr (assoc 1 (entget blk)))))))
val)
;; Set Attribute Value - Lee Mac
;; Sets the value of the first attribute with the given tag found within the block, if present.
;; blk - [ent] Block (Insert) Entity Name
;; tag - [str] Attribute TagString
;; val - [str] Attribute Value
;; Returns: [str] Attribute value if successful, else nil.
(defun LM:setattributevalue ( blk tag val / enx )
(if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
(if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
(if (entmod (subst (cons 1 val) (assoc 1 (reverse enx)) enx))
(progn
(entupd blk)
val))
(LM:setattributevalue blk tag val))))
; ------------------------------------------------------------------------------------------------------------
(if (and (or (tblsearch "BLOCK" "OBEM")
(prompt "\nError: No 'OBEM' block for volume report found in the drawing."))
(setq enl (entlast))
(setq pnt (getpoint "\nPick Inner point to place the block: "))
(vl-cmdf "_.UNDO" "_Mark")
(setq und T)
(vl-cmdf "_.BOUNDARY" "_Advanced" "_Island" "_No" "" "" "_none" pnt "")
(not (equal enl (setq enl (entlast))))
(setq ss (ssget "_F"
(mapcar '(lambda (y) (trans (cdr y) 0 1))
(vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget enl)))
'((0 . "INSERT") (2 . "project-t*rrain*"))))
(not (command-s "_.SELECT" ss))
(setq ss (ssget "_P" '((0 . "INSERT") (2 . "project-t*rrain*"))))
)
(progn
(command "_.AREA")
(repeat (setq i (sslength ss))
(setq en (ssname ss (setq i (1- i))))
(if (setq val (:GetAttValByTag en "PROJECT-TRRAIN"))
(setq lst (cons val lst)))
(command (cdr (assoc 10 (entget en)))))
(command "")
(setq are (getvar 'AREA)
avr (abs (/ (apply '+ lst) (float (length lst))))
vol (* are avr 0.01)
num (getstring "\nBlock number: ")
idx (getstring "\nBlock index: ")
atd (getvar 'ATTDIA)
atr (getvar 'ATTREQ))
(command "_UNDO" "_Back")
(setq und nil)
(setvar 'ATTDIA 0)
(setvar 'ATTREQ 1)
(command "_.INSERT" "OBEM" "_Scale" 0.2 "_Rotate" 0 "_none" pnt
idx
(rtos vol 2 2)
(rtos are 2 2)
(rtos avr 2 2)
num)))
(*error* "end")
)
