Need a small change in Lisp Code Please

July 11, 2019

Hai all, i have a lisp that gives me Length and Width of Rectangles that i select into a Table in cad. the table gives me the length and width as per incremental in size (eg:{ 1x2, 1.2x2, 2.1x3 } like wise) i have attached a screenshot of this, and also joins same size rectangle in one cell and shows number as 2.

What i need help is to get the table not as incremental values but as i select (1st selection in first cell, 2nd in second cell like that). Please check the Screen shot.

i don't know how to change the codes, the lisp is from a friend i got. so please help if possible , thanks in advance.. Please check the image ive uploaded too.

the lisp code:

(defun rectangle_dims (e / l a b)
  (setq l (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) e)))
  (if
    (and
      (or
        (= 1 (logand (cdr (assoc 70 e)) 1))
        (equal (car l) (last l) 1e-8)
      )
      (equal (distance  (car   l) (caddr l)) (distance  (cadr   l) (cadddr l)) 1e-8)
      (equal (mapcar '- (cadr  l) (car   l)) (mapcar '- (caddr  l) (cadddr l)) 1e-8)
      (equal (mapcar '- (caddr l) (cadr  l)) (mapcar '- (cadddr l) (car    l)) 1e-8)
    )
    (vl-sort (list (distance (car l) (cadr l)) (distance (cadr l) (caddr l))) '<)
  )
)

(defun C:RECDIMS (/ acObj acDoc space *error* ss e old r p1)
  (vl-load-com)
  (setq acObj (vlax-get-acad-object)
        acDoc (vla-get-activedocument acObj)
        space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
  )
  (vla-startundomark acDoc)
  
  ;;;;;; Error function ;;;;;;;;;
  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
      (princ (strcat "\nError: " msg))
      )
    (vla-endundomark acDoc)
    (princ)
    )
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  (if
    (setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "<OR") (90 . 4) (90 . 5) (-4 . "OR>"))))
    (progn
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (if
          (setq dims (rectangle_dims (entget e)))
          (if
            (setq old (vl-some '(lambda (d) (if (equal (list (cadr d) (caddr d)) dims 1e-8) d)) r))
            (setq r (subst (cons (1+ (car old)) dims) old r))
            (setq r (cons (cons 1 dims) r))
          )
        )
      )
      (if
        (and r (setq p1 (getpoint "\nSpecify table insert point: ")))
        (insert_table
          (mapcar
            '(lambda (a)
               (list (cadr a) (caddr a) (car a))
               )
            (vl-sort (vl-sort r '(lambda (a b) (< (caddr a) (caddr b)))) '(lambda (a b) (< (cadr a) (cadr b))))
            )
          p1
          )       
         )
       )
    )
  (princ)
)

;;The textheight in table depends on cannonscale
(defun insert_table (lst pct / tab row col ht i n)
  (setq ht  (/ 2.5 (getvar 'cannoscalevalue))
        pct (trans pct 1 0)
        n   (trans '(1 0 0) 1 0 T)
        tab (setq tab (vla-addtable space (vlax-3d-point pct) (+ 2 (length lst)) (length (car lst)) (* 2.5 ht) ht))
        )
  (vlax-put tab 'direction n)
  
  (mapcar
    (function
      (lambda (rowType)
        (vla-SetTextStyle  tab rowType (getvar 'textstyle))
        (vla-SetTextHeight tab rowType ht)
      )
    )
   '(2 4 1)
  )
  
  (vla-put-HorzCellMargin tab (* 0.14 ht))
  (vla-put-VertCellMargin tab (* 0.14 ht))

  (setq lst (cons '("Width" "Length" "Pcs.") lst))

  (setq i 0)
  (foreach col (apply 'mapcar (cons 'list lst))
    (vla-SetColumnWidth tab i
      (apply
        'max
        (mapcar
          '(lambda (x)
             ((lambda (txb) (+ (abs (- (caadr txb) (caar txb))) (* 2.0 ht)))
              (textbox (list (cons 1 (vl-princ-to-string x)) (cons 7 (getvar 'textstyle)) (cons 40 ht)))
              )
             )
          col
          )
        )
      )
    (setq i (1+ i))
    )
  
  (setq lst (cons '("RECTANGLES") lst))
  
  (setq row 0)
  (foreach r lst
    (setq col 0)
    (vla-SetRowHeight tab row (* 1.5 ht))
    (foreach c r
      (vla-SetText tab row col (vl-princ-to-string c))
      (setq col (1+ col))
      )
    (setq row (1+ row))
    )
  )
  
(princ "\nType RECDIMS to start the command")

July 11, 2019

Try this. I rewrote most of it

I don't know how to handle tables (in lisp) well, I hardcoded the size of things. So I hope you have a text height of 2.5, else this needs some more work


(defun rectangle_dims (e / l a b)
  (setq l (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) e)))
  (if
    (and
      (or
        (= 1 (logand (cdr (assoc 70 e)) 1))
        (equal (car l) (last l) 1e-8)
      )
      (equal (distance  (car   l) (caddr l)) (distance  (cadr   l) (cadddr l)) 1e-8)
      (equal (mapcar '- (cadr  l) (car   l)) (mapcar '- (caddr  l) (cadddr l)) 1e-8)
      (equal (mapcar '- (caddr l) (cadr  l)) (mapcar '- (cadddr l) (car    l)) 1e-8)
    )
    (vl-sort (list (distance (car l) (cadr l)) (distance (cadr l) (caddr l))) '<)
  )
)

(defun inserttable (lst pt / ht tab i j row tb)
 
  (setq ht 2.5)
  (setq tab (setq tab (vla-addtable space (vlax-3d-point pt) (length lst) (length (cadr lst)) (* 1.1 ht) (* 10.0 ht))))
  (vla-SetTextHeight tab 1 ht)
  (vla-SetTextHeight tab 2 ht)
  (vla-SetTextHeight tab 4 ht)
 
  (vla-setcolumnwidth tab 0 20.0)
  (vla-setcolumnwidth tab 1 40.0)
 
  (vla-put-HorzCellMargin tab (* 0.14 ht))
  (vla-put-VertCellMargin tab (* 0.14 ht))
 
  (setq i 0)
  (repeat (length lst)  ;; iterates the rows
    (vla-setrowHeight tab i 4.0)
    (setq row (nth i lst))
    (setq j 0)
    (repeat (length row)  ;; iterates the cols in the row
      (vla-SetText tab i j (nth j row) )
      (setq j (+ j 1))
    )
    (setq i (+ i 1))
  )
)

(defun c:recdims ( / ss i e lst)
  (vl-load-com)
  (setq acObj (vlax-get-acad-object)
        acDoc (vla-get-activedocument acObj)
        space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
  )
  (vla-startundomark acDoc)
  (setq i 0)
  (setq lst (list (list "Area Table") (list "Numbers" "Length & Width")))    ;; head / titles of the table
  (if
    (setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "<OR") (90 . 4) (90 . 5) (-4 . "OR>"))))
    (progn
      (repeat (sslength ss)
        (setq e (ssname ss i))
        (princ "\n")
        (princ  (setq dims (rectangle_dims (entget e))) )
        (setq lst (append lst (list
          (list
            (itoa (+ i 1))
            (strcat "L = " (rtos (cadr dims) 2 2 ) ", W = "  (rtos (car dims) 2 2 ))
          )            
        )))
        (setq i (+ i 1))
      )
      (setq p1 (getpoint "\nSpecify table insert point: "))
      (inserttable lst p1)
    )
  )
  (princ)
)

(princ "\nType RECDIMS to start the command")
(princ)

July 13, 2019

On 7/11/2019 at 3:01 PM, Emmanuel Delay said:

Try this. I rewrote most of it

I don't know how to handle tables (in lisp) well, I hardcoded the size of things. So I hope you have a text height of 2.5, else this needs some more work


(defun rectangle_dims (e / l a b)
  (setq l (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) e)))
  (if
    (and
      (or
        (= 1 (logand (cdr (assoc 70 e)) 1))
        (equal (car l) (last l) 1e-8)
      )
      (equal (distance  (car   l) (caddr l)) (distance  (cadr   l) (cadddr l)) 1e-8)
      (equal (mapcar '- (cadr  l) (car   l)) (mapcar '- (caddr  l) (cadddr l)) 1e-8)
      (equal (mapcar '- (caddr l) (cadr  l)) (mapcar '- (cadddr l) (car    l)) 1e-8)
    )
    (vl-sort (list (distance (car l) (cadr l)) (distance (cadr l) (caddr l))) '<)
  )
)

(defun inserttable (lst pt / ht tab i j row tb)
 
  (setq ht 2.5)
  (setq tab (setq tab (vla-addtable space (vlax-3d-point pt) (length lst) (length (cadr lst)) (* 1.1 ht) (* 10.0 ht))))
  (vla-SetTextHeight tab 1 ht)
  (vla-SetTextHeight tab 2 ht)
  (vla-SetTextHeight tab 4 ht)
 
  (vla-setcolumnwidth tab 0 20.0)
  (vla-setcolumnwidth tab 1 40.0)
 
  (vla-put-HorzCellMargin tab (* 0.14 ht))
  (vla-put-VertCellMargin tab (* 0.14 ht))
 
  (setq i 0)
  (repeat (length lst)  ;; iterates the rows
    (vla-setrowHeight tab i 4.0)
    (setq row (nth i lst))
    (setq j 0)
    (repeat (length row)  ;; iterates the cols in the row
      (vla-SetText tab i j (nth j row) )
      (setq j (+ j 1))
    )
    (setq i (+ i 1))
  )
)

(defun c:recdims ( / ss i e lst)
  (vl-load-com)
  (setq acObj (vlax-get-acad-object)
        acDoc (vla-get-activedocument acObj)
        space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
  )
  (vla-startundomark acDoc)
  (setq i 0)
  (setq lst (list (list "Area Table") (list "Numbers" "Length & Width")))    ;; head / titles of the table
  (if
    (setq ss (ssget '((0 . "LWPOLYLINE") (-4 . "<OR") (90 . 4) (90 . 5) (-4 . "OR>"))))
    (progn
      (repeat (sslength ss)
        (setq e (ssname ss i))
        (princ "\n")
        (princ  (setq dims (rectangle_dims (entget e))) )
        (setq lst (append lst (list
          (list
            (itoa (+ i 1))
            (strcat "L = " (rtos (cadr dims) 2 2 ) ", W = "  (rtos (car dims) 2 2 ))
          )            
        )))
        (setq i (+ i 1))
      )
      (setq p1 (getpoint "\nSpecify table insert point: "))
      (inserttable lst p1)
    )
  )
  (princ)
)

(princ "\nType RECDIMS to start the command")
(princ)

Thank you so much, it works great...

Just one more help if possible. is it possible to combine TWO lisp codes so it works as one?

Sign In

Need a small change in Lisp Code Please

Recommended Posts

minejash

Emmanuel Delay

minejash

Join the conversation

Tutorials

Forums

Activity