Jump to content

Need a small change in Lisp Code Please


minejash

Recommended Posts

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")
             

  

 

for lisp query-Model.jpg

Link to comment
Share on other sites

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)

Link to comment
Share on other sites

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?

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...