Help to Update a lisp code : Calculate data from attribute block and export to mtext

[mhy3sx]

Hi I write this code to check some areas from window block attribute

 

The code works perfect but I need to do an update.

This code select the attribiute blocks and inset in mtext some data from the windows and calculate area from eatch window and sum all the areas

 

I want

1) if it is possible  to add m2 after

 

      (setq table (append table (list (list "Sum" "" "" (round total-embadon 0.001)))))

I try to do it but at the end of eatch column add m2

 

2) Some times I check areas from Purchase Invoice and some time the areas have 3 decimals  or the areas not round up for example (3.555 = 3.56  but the write 3.55)  and the sum is not correct. So I add Two toggle

 

In the fist toggle if it is check I want the calculations to done with 3 decimals and if it uncheck the calculations use 2 decimals

 

And the second toggle if it is check not round up the calculations ,and if it is uncheck round up the calculations

 

Can any one help me to fix this ?

 

(defun c:test (/ *error* dch dcl msg des drv _option1 _option2 _option3)

;------------

(defun _option1 (/ ss i blk table total-embadon pl yp embadon att-list att att-tag scl ht mtext-str insert-point category-str u)

  ;; Initialize the table with headers (removed α/α. column)
  (setq table (list (list "width" "H" "Area" "u")))
  ;; Initialize the total ΕΜΒΑΔΟΝ to 0
  (setq total-embadon 0)
  
  ;; Prompt user to select blocks
  (setq ss (ssget '((0 . "INSERT")))) ; Select all blocks (INSERT entities)

  (if ss
    (progn
      (setq i 0)  ; Initialize row counter
      ;; Loop through the selection set
      (repeat (sslength ss)
        (setq ent (ssname ss i))
        (setq ent-data (entget ent))  ; Extract the entity data

        ;; Check if the selected entity is a valid INSERT (block reference)
        (if (and ent-data (= (cdr (assoc 0 ent-data)) "INSERT"))
            (progn
              ;; Convert entity to VLA-Object (Block reference object)
              (setq blk (vlax-ename->vla-object ent))

              ;; Get the block's attributes
              (setq att-list (vlax-invoke blk 'GetAttributes))

              ;; Initialize variables for attributes
              (setq pl nil yp nil category-str nil u nil)

              ;; 
              (foreach att att-list
                (setq att-tag (strcase (vla-get-tagstring att)))  ; Get the attribute tag name
                (cond
                  ((= att-tag "PL") (setq pl (vla-get-textstring att))) 
                  ((= att-tag "H") (setq yp (vla-get-textstring att)))  
                  ((= att-tag "Title") (setq category-str (vla-get-textstring att))) 
                  ((= att-tag "U") (setq u (vla-get-textstring att)))  
                )
              )

              ;; Ensure all attributes exist and are not nil before continuing
              (if (and pl yp category-str u)
                  (progn
                    ;; Calculate
                    (setq embadon (* (atof pl) (atof yp)))

                    ;; Insert data into the table
                    (setq table (append table (list (list pl yp embadon u))))
                    ;; Update the total  sum
                    (setq total-embadon (+ total-embadon embadon))
                  )
              )
            )
        )
        (setq i (1+ i))  ; Increment loop counter
      )

      ;; Add the  row (Total sum)
      (setq table (append table (list (list "Sum" "" "" (round total-embadon 0.001)))))

      ;; Get scale and height
      (setq scl (getvar "useri1"))
      (setq ht (* 0.0025 scl))  ;; Calculate text height (adjusted for scale)

      ;; Prepare the MTEXT string 
      (setq mtext-str (strcat "title " category-str "\n\n")) ; Add 

      (foreach row table
        (setq row-str (apply 'strcat (mapcar '(lambda (x) (strcat (if (numberp x) (rtos x 2 3) x) "        ")) row))) ; 8 spaces between columns
        (setq mtext-str (strcat mtext-str row-str "\n"))
      )

      ;;
      (setq mtext-str (strcat mtext-str "\n"))

      ;; Prompt the user to select an insertion point
      (setq insert-point (getpoint "\nPick point to insert text: "))

      ;; Create the MTEXT entity using entmake
      (entmake
        (list
          (cons 0 "MTEXT")           ;; Entity Name
          (cons 100 "AcDbEntity")    ;; Subclass Marker
          (cons 410 "Model")         ;; Space (Model Space)
          (cons 8 "0")               ;; Layer (Layer 0)
          (cons 100 "AcDbMText")     ;; Subclass Marker for MTEXT
          (cons 10 insert-point)     ;; Insertion Point (Picked by user)
          (cons 40 ht)               ;; Text Height
          (cons 71 1)                ;; Attachment Point (Top-left corner)
          (cons 1 mtext-str)         ;; Text Content (Table content)
          (cons 7 "Arial")           ;; Text Style (Arial)
          (cons 50 0)                ;; Rotation (0 grads)
        ) 
      )

      ;; Print the table to the command line (optional)
      (princ "\nTable: \n")
      (foreach row table
        (foreach cell row
          (princ (strcat (if (numberp cell) (rtos cell 2 3) cell) "\t")))
        (princ "\n"))

    )
    (alert "No blocks selected.")
  )
  (princ)  ; Exit gracefully
)


;-------------

(defun _option2 (/ ss i blk table total-embadon pl yp embadon att-list att att-tag scl ht mtext-str insert-point category-str u)

  ;; Initialize the table with headers (removed α/α. column)
  (setq table (list (list "πλάτος" "ύψος" "εμβαδόν" "u")))
  ;; Initialize the total ΕΜΒΑΔΟΝ to 0
  (setq total-embadon 0)
  
  ;; Prompt user to select blocks
  (setq ss (ssget '((0 . "INSERT")))) ; Select all blocks (INSERT entities)

  (if ss
    (progn
      (setq i 0)  ; Initialize row counter
      ;; Loop through the selection set
      (repeat (sslength ss)
        (setq ent (ssname ss i))
        (setq ent-data (entget ent))  ; Extract the entity data

        ;; Check if the selected entity is a valid INSERT (block reference)
        (if (and ent-data (= (cdr (assoc 0 ent-data)) "INSERT"))
            (progn
              ;; Convert entity to VLA-Object (Block reference object)
              (setq blk (vlax-ename->vla-object ent))

              ;; Get the block's attributes
              (setq att-list (vlax-invoke blk 'GetAttributes))

              ;; Initialize variables for attributes
              (setq pl nil yp nil category-str "Title E1" u nil)  ; Assign fixed title for Κατηγορία

              ;; 
              (foreach att att-list
                (setq att-tag (strcase (vla-get-tagstring att)))  ; Get the attribute tag name
                (cond
                  ((= att-tag "PL") (setq pl (vla-get-textstring att))) 
                  ((= att-tag "H") (setq yp (vla-get-textstring att))) 
                  ((= att-tag "U") (setq u (vla-get-textstring att))) 
                )
              )

              ;; Ensure all attributes exist and are not nil before continuing
              (if (and pl yp u)
                  (progn
                    ;; 
                    (setq embadon (* (atof pl) (atof yp)))

                    ;; 
                    (setq table (append table (list (list pl yp embadon u))))
                    ;; Update the total sum
                    (setq total-embadon (+ total-embadon embadon))
                  )
              )
            )
        )
        (setq i (1+ i))  ; Increment loop counter
      )

      ;; Add the row (Total sum)
      (setq table (append table (list (list "Sum" "" "" (round total-embadon 0.001)))))

      ;; Get scale and height
      (setq scl (getvar "useri1"))
      (setq ht (* 0.0025 scl))  ;; Calculate text height (adjusted for scale)

      ;; Prepare the MTEXT string with the Κατηγορία info
      (setq mtext-str (strcat "Title E1\n\n")) 

      (foreach row table
        (setq row-str (apply 'strcat (mapcar '(lambda (x) (strcat (if (numberp x) (rtos x 2 3) x) "        ")) row))) ; 8 spaces between columns
        (setq mtext-str (strcat mtext-str row-str "\n"))
      )

    
      (setq mtext-str (strcat mtext-str "\n"))

      ;; Prompt the user to select an insertion point
      (setq insert-point (getpoint "\nPick point to insert text: "))

      ;; Create the MTEXT entity using entmake
      (entmake
        (list
          (cons 0 "MTEXT")           ;; Entity Name
          (cons 100 "AcDbEntity")    ;; Subclass Marker
          (cons 410 "Model")         ;; Space (Model Space)
          (cons 8 "0")               ;; Layer (Layer 0)
          (cons 100 "AcDbMText")     ;; Subclass Marker for MTEXT
          (cons 10 insert-point)     ;; Insertion Point (Picked by user)
          (cons 40 ht)               ;; Text Height
          (cons 71 1)                ;; Attachment Point (Top-left corner)
          (cons 1 mtext-str)         ;; Text Content (Table content)
          (cons 7 "Arial")           ;; Text Style (Arial)
          (cons 50 0)                ;; Rotation (0 grads)
        ) 
      )

      ;; Print the table to the command line (optional)
      (princ "\nTable: \n")
      (foreach row table
        (foreach cell row
          (princ (strcat (if (numberp cell) (rtos cell 2 3) cell) "\t")))
        (princ "\n"))

    )
    (alert "No blocks selected.")
  )
  (princ)  ; Exit gracefully
)


;-------------

(defun _option3 (/ ss i blk table total-embadon a/a pl yp embadon att-list att att-tag scl ht mtext-str insert-point pline total-length window-area etherm height)

  ;; Initialize the table with headers
  (setq table (list (list "NO." "WIDTH" "H" "AREA")))
  ;; Initialize the total ΕΜΒΑΔΟΝ to 0
  (setq total-embadon 0)

  ;; Step 1: Prompt for polyline selection and calculate its length
  (princ "\nSelect polyline(s) for calculate length:")
  ;(setq ss (ssget '((0 . "POLYLINE,LWPOLYLINE")))) ; Get only polylines and lightweight polylines
  
  ;----Επιλογή Polyline και αλλαγή Layer------------------------
  
 (command "_layer" "_m" "THERM_Path" "_c" "10" "" "")

  (and (setq ss (ssget '((0 . "POLYLINE,LWPOLYLINE"))))
       ((lambda (int / sn lst pos)
          (while (setq lst nil
                       int (1+ int)
                       sn  (ssname ss int)
                 )
            (foreach dxf (entget sn)
              (or (and (setq pos (vl-position (car dxf) '(8 40 41 43)))
                       (setq lst (cons (cons (car dxf) (nth pos '("THERM_Path" 0.05 0.05 0.05))) lst)) ; ορισμός global σε 0.05 
                       )
                  (setq lst (cons dxf lst)))
              )
            (entmod (reverse lst))
            )
          )
         -1
       )
  )
  
  ;-----------------------
  (if ss
    (progn
      (setq total-length 0.0)
      ;; Loop through selected polylines and calculate total length
      (setq i 0)
      (while (setq e (ssname ss i))
        (setq ent (entget e))
        (setq obj (cdr (assoc 0 ent)))

        ;; Calculate length based on object type
        (setq length
              (cond
                ((= obj "LINE")
                 (distance (cdr (assoc 10 ent)) (cdr (assoc 11 ent))))  ;; Length of line
                ((or (= obj "POLYLINE") (= obj "LWPOLYLINE"))
                 (setq length (vla-get-length (vlax-ename->vla-object e))))  ;; Length of polyline (LWPOLYLINE, POLYLINE)
                (T 0)  ;; Default case for unsupported objects
              ))

        ;; Round the length to 3 decimal places before adding it
        (setq total-length (+ total-length (round length 0.001)))  ;; Add the calculated length to the total length
        (setq i (1+ i))  ;; Increment the loop counter
      )

      ;; Display the total length in the command line, rounded to 3 decimals
      (princ (strcat "\nLENGTH OF PLYLINE: " (rtos (round total-length 0.001) 2 3)))
    )
    (princ "\nNo polylines selected!")
  )

  ;; Step 2: Prompt for window block selection
  (princ "\nsELECTblock(s)FOR CALCULATION :")
  (setq ss (ssget '((0 . "INSERT")))) ; Select all blocks (INSERT entities)

  (if ss
    (progn
      (setq i 0)  ; Initialize row counter
      ;; Loop through the selection set
      (repeat (sslength ss)
        (setq ent (ssname ss i))
        (setq ent-data (entget ent))  ; Extract the entity data

        ;; Check if the selected entity is a valid INSERT (block reference)
        (if (and ent-data (= (cdr (assoc 0 ent-data)) "INSERT"))
            (progn
              ;; Convert entity to VLA-Object (Block reference object)
              (setq blk (vlax-ename->vla-object ent))

              ;; Get the block's attributes
              (setq att-list (vlax-invoke blk 'GetAttributes))

              ;; Initialize variables for attributes
              (setq a/a nil)
              (setq pl nil)
              (setq yp nil)


              (foreach att att-list
                (setq att-tag (strcase (vla-get-tagstring att)))  ; Get the attribute tag name
                (cond
                  ((= att-tag "NO.") (setq a/a (vla-get-textstring att))) 
                  ((= att-tag "PL") (setq pl (vla-get-textstring att)))  
                  ((= att-tag "H") (setq yp (vla-get-textstring att)))
                )
              )

              ;; Ensure all attributes exist and are not nil before continuing
              (if (and a/a pl yp (not (eq a/a nil)) (not (eq pl nil)) (not (eq yp nil)))
                  (progn
      
                    (setq embadon (* (atof pl) (atof yp)))

           
                    (setq embadon (round embadon 0.001))


                    (setq table (append table (list (list a/a pl yp embadon))))

                    (setq total-embadon (+ total-embadon embadon))
                  )  ; End of valid attribute block processing
              )  ; End of if check for valid attributes
            )  ; End of valid INSERT entity check
        )
        (setq i (1+ i))  ; Increment loop counter
      )

      ;; Add the ΣΥΝΟΛΟ row (Total sum)
      (setq table (append table (list (list "Sum" "        " "" (round total-embadon 0.001)))))

      ;; Step 3: Ask for height input (e.g., 1.8)
      (setq height (getreal "\nGive H (2.80): "))

      ;; Round height to 3 decimals
      (setq height (round height 0.001))

      ;; Step 4: Calculate Eθερμ (thermal insulation)
      (setq window-area total-embadon) ;; This is the total window area calculated earlier
      (setq etherm (- (* total-length height) window-area))

      ;; Round the etherm result to 3 decimal places
      (setq etherm (round etherm 0.001))

      ;; Get scale and height for MText
      (setq scl (getvar "useri1"))
      (setq ht (* 0.0025 scl))  ;; Calculate text height (adjusted for scale)

      ;; Initialize the MTEXT string
      (setq mtext-str "")


      (setq mtext-str (strcat mtext-str "1. Length = " (rtos (round total-length 0.001) 2 3) " m"))
      (setq mtext-str (strcat mtext-str "\n\n2. Area\n"))

      ;; Add table rows to MText (including "m2" after each value)
      (foreach row table
        (setq row-str (apply 'strcat (mapcar '(lambda (x) (strcat (if (numberp x) (rtos x 2 3) x) "        ")) row))) ; 8 spaces between columns
        (setq mtext-str (strcat mtext-str row-str  "\n"))
      )

      ;; Add final calculation line for Eθερμ.
      (setq mtext-str (strcat mtext-str "\n\n3. Area for H = " (rtos height 2 2) " m"))
      (setq mtext-str (strcat mtext-str "\nArea therm = (" (rtos (round total-length 0.001) 2 3) " x " (rtos height 2 2) ") - " (rtos window-area 2 3) " = " (rtos etherm 2 3) " m2"))

      ;; Prompt the user to select an insertion point for the MText
      (setq insert-point (getpoint "\nPick point to insert Area: "))

      ;; Create the MTEXT entity using entmake
      (entmake
        (list
          (cons 0 "MTEXT")           ;; Entity Name
          (cons 100 "AcDbEntity")    ;; Subclass Marker
          (cons 410 "Model")         ;; Space (Model Space)
          (cons 8 "0")               ;; Layer (Layer 0)
          (cons 100 "AcDbMText")     ;; Subclass Marker for MTEXT
          (cons 10 insert-point)     ;; Insertion Point (Picked by user)
          (cons 40 ht)               ;; Text Height
          (cons 71 1)                ;; Attachment Point (Top-left corner)
          (cons 1 mtext-str)         ;; Text Content (Table content)
          (cons 7 "Arial")           ;; Text Style (Arial)
          (cons 50 0)                ;; Rotation (0 grads)
        )
      )

      ;; Print the table to the command line (optional)
      (princ "\nTable: \n")
      (foreach row table
        (foreach cell row
          (princ (strcat (if (numberp cell) (rtos cell 2 3) cell) "\t")))
        (princ "\n"))

    )  ; End of sscheck
    (alert "No blocks selected.")
  )  ; End of ssselect

  (princ)  ; Exit gracefully
)



;-------------------------------DCL MENU------------------------------------------------------------------------------------
  
    (defun *error* (msg)
    (if (and (= 'int (type dch)) (< 0 dch))(unload_dialog dch))
    (if (= 'file (type des))(close des))
    (if (and (= 'str (type dcl)) (findfile dcl))(vl-file-delete dcl))
    (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
      (princ (strcat "\nError: " msg)))
    (princ)
  )
  
  (setvar "OSMODE" 13)
  (if (not (and (setq dcl (vl-filename-mktemp nil nil ".dcl"))(setq des (open dcl "w"))))
    (princ "\nUnable to open DCL for writing.")
       (foreach str
                '(
                  "ed : edit_box { alignment = left; width = 25; edit_width = 10; fixed_width = true;}"
                  ""
                  "Parartima : dialog { spacer; key = \"dcl\";"
                  " : row {"	
                  " : boxed_radio_column {label = \"Παράρτημα VI \";"
                  "    : radio_button { height = 1.0; width = 25; is_tab_stop = true;"
                  "      key = \"radio_button01\"; label = \"1. Option1\";"
                  "  }" 
                  "    : radio_button { height = 1.0; width = 25; is_tab_stop = true;"
                  "      key = \"radio_button02\"; label = \"2. Option2\";"
                  "  }" 
                  "    : radio_button { height = 1.0; width = 25; is_tab_stop = true;"
                  "      key = \"radio_button03\"; label = \"3. Option3\";"
                  "  }" 
                  "}"				  	  

                  " : boxed_radio_column {label = \"Settings \";"
                "      : toggle { height = 1.0; width = 20; is_tab_stop = true;"
                "        key = \"threedecimals\"; label = \"3 decimals \";"
                "    }" 
                "      : toggle { height = 1.0; width = 20; is_tab_stop = true;"
                "        key = \"roundup\"; label = \"No Roundup\";"
                "    }" 
                  "}"
                  "	}"
                  "  ok_only;"
                  "}"
                 )
         (write-line str des)
       ) ;;; end foreach
  ) ;;; end if
  (if des (progn (close des)(gc)))

  (if (and (setq dch (load_dialog dcl)) (new_dialog "Parartima" dch))
    (progn
	 (set_tile "dcl" "Calculations")
      (action_tile "radio_button01" "(setq sng 1)")
      (action_tile "radio_button02" "(setq sng 2)")
      (action_tile "radio_button03" "(setq sng 3)")
      (action_tile "accept" "(done_dialog 1)")
      (action_tile "cancel" "(done_dialog 0)")
      ;;; dialog return value
      (setq drv (start_dialog))
      ;;; once loaded , get rid of temp dcl file
      (if (and dcl (findfile dcl))(vl-file-delete (findfile dcl)))
      (cond
	((= drv  0))
	((= drv  1)
         (cond
           ((= sng 1)(_Option1))
           ((= sng 2)(_Option2))
           ((= sng 3)(_Option3))
         )
        )
       )
    )
  )
  (princ)
 
) 

 

 

Thanks

Edited Monday at 04:01 PM by mhy3sx

[BIGAL]

First comment need a dwg to see what is going on. 

 

When you use get-attributes it returns the attributes in the edit order so no need to look for tag name just use the (nth x atts) and get the textstring.

 

(setq pl (vla-get-textstring (nth 0 att-list)))
(setq yp (vla-get-textstring (nth 1 att-list)))  
(setq category-str (vla-get-textstring (nth 2 att-list))) 

This is a library routine your welcome to use it auto loads the make dcl from a list and returns the radio button selected. Examples at top of code.

Multi radio buttons.lsp

[mhy3sx]

Hi bigal. The code works but the problem is how to make the toggles work

 

 

In the fist toggle if it is check I want the calculations to done with 3 decimals and if it uncheck the calculations use 2 decimals

 

And the second toggle if it is check not round up the calculations ,and if it is uncheck round up the calculations

Thanks

[hosneyalaa]

can you

share example drawing

[mhy3sx]

Hi hosneyalaa. The block is not in english and the font will be not regognized in other languages. I translate the tags in the code. The code I have works have no error . I want to see what t o change in the code to work the toggle

 

 

In the fist toggle if it is check I want the calculations to done with 3 decimals and if it uncheck the calculations use 2 decimals

 

And the second toggle if it is check not round up the calculations ,and if it is uncheck round up the calculations

[BIGAL]

have a look at the Multi radio buttons code and you will see what it returns. Try this can be copied to command line.

(if (not AH:Butts)(load "Multi radio buttons.lsp"))
(if (= but nil)(setq but 1))
(setq ans (ah:butts but "V"   '("Choose A B C D " "A" "B" "C" "D" )))

 You could do choose 2decs, 3decs 

 

The attached is two columns of choices. Again see examples.

Multi radio buttons 2col.lsp

[mhy3sx]

Hi BiGAl , I can not understand how Multi radio buttons work.I want to design the DCL dialog as I want , not radom by a lisp.

 

Thanks

[Steven P]

So there is nothing wrong with using something that already exists, if it isn't quite perfect but saves you hours of programming time you'll have to work out if that is a good compromise. Multi-radio buttons is generally versatile and one most of us should have in our LISP library.

 

I am not sure if you have looked but AfraLisp website has some good tutorials which might help you here.

[BIGAL]

Just change this line, and it will write a dcl for you then you can see the code produced.

 

(setq fo (open (setq fname (vl-filename-mktemp "" "" ".dcl")) "w"))

(setq fo (open (setq fname "D:\\yourdirectory\\yourfilename.dcl") "w"))