Jump to content

help routine for selection lines and inserting table

PedroSoa

By PedroSoa
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

PedroSoa Apprentice

PedroSoa

Posted
Posted 
(defun C:LAYLENGTH ( / *error* acdoc ss p i e a d l) (vl-load-com)
  (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark acdoc)
  

  (defun *error* (msg)
		(and
		  msg
		  (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*,*EXIT*"))
		  (princ (strcat "\nError: " msg))
		)
    (if
      (= 8 (logand (getvar 'undoctl) 8))
      (vla-endundomark acdoc)
    )
    (princ)
    )
 
  
 ;Select lines 
  (if
    (and
      (setq ss (ssget ":L" '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE"))))
      (setq p (getpoint "\nTable scale depend on annotation scale.\nSpecify table insert point: "))
	  	 )	  
    (progn
      (repeat
        (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i)))
              a (cdr (assoc 8 (entget e)))
              d (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
        )        
		(if
          (setq o (assoc a l))
          (setq l (subst (list a (+ (cadr o) d)) o l))
          (setq l (cons (list a d) l))
        )
      )
      (setq l (vl-sort l '(lambda (a b) (< (car a) (car b)))))
      (setq ln (nth 0 l))
       
	  
	  	;;SEAM (TYPE & Stich Density)
	(defun SEAM (ln)
	(setq st 0)
	;Pergunta por SEAM TYPE 
	(while (not (or (= st 301) (= st 401))) 
	  (setq st (getint "\nEnter Seam Type: "))
		)	  
	(print st)	
	;Stich density
	(setq sd (getint "\nEnter Stitch Density: "))
	(print sd)
	;Upper and Lowe Thread
	(if (= st 301)
	(progn (setq Upperthread301 (* 1.2 (* ln (+ 1 (/ 13.5 sd )))))
	(princ sd)
		(setq Lowerthread301 (* 0.8 (* ln (+ 1 (/ 13.5 sd )))))
	(princ sd)
	)	
	)
	(if (= st 401)    
	(progn (setq Upperthread401 (* ln (+ 1 (/ 26.5 sd ))))	
(princ Upperthread401)
	;(setq row (3+ row)
	(setq Lowerthread401 (* ln (+ 1 (/ 13.5 sd ))))
(princ Lowerthread401)
	;(setq row (4+ row)
	)
	)
	  
	  
	  
      (insert_table l p)
      )
    )
  (*error* nil)
  (princ)
  )
  
  
  
;Insert table
(defun insert_table (lst pct / tab row col ht i n space)
  (setq space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
        ht  (/ 2.5 (cond ((getvar 'cannoscalevalue)) (1.0)))
        pct (trans pct 1 0)
        n   (trans '(1 0 0) 1 0 T)
		;4 linhas em (+ 4 (length lst)
        tab (setq tab (vla-addtable space (vlax-3d-point pct) (+ 4 (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 (mapcar '(lambda (a) (strcat "Col" (itoa (1+ (vl-position a (car lst)))))) (car lst)) 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 '("TITLE") 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 (if (numberp c) (rtos c) (vl-princ-to-string c)))
				  (setq col (1+ col))
				  )
			(setq row (1+ row))	
		)
	
	
	
  )
  
    
(Princ))

i need help to resolve my problem! any help!? 

Link to comment
Share on other sites
rlx Veteran

rlx

Posted
Posted

I believe you have to check your code some more. Your if statement has 3 arguments while only 2 are allowed

Besides that , in your if statement you (defun SEAM ...) but never use (call) it 


;Select lines
  (if
    (and
      (setq ss (ssget ":L" '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE"))))
      (setq p (getpoint "\nTable scale depend on annotation scale.\nSpecify table insert point: "))
           )      
    (progn
      (repeat
        (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i)))
              a (cdr (assoc 8 (entget e)))
              d (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
        )        
        (if
          (setq o (assoc a l))
          (setq l (subst (list a (+ (cadr o) d)) o l))
          (setq l (cons (list a d) l))
        )
      )
      (setq l (vl-sort l '(lambda (a b) (< (car a) (car b)))))
      (setq ln (nth 0 l))
       
      
          ;;SEAM (TYPE & Stich Density)
    (defun SEAM (ln)
    (setq st 0)
    ;Pergunta por SEAM TYP.....

 

  • Like 1
Link to comment
Share on other sites
PedroSoa Apprentice

PedroSoa

Posted
  • Author
Posted

thanks a lot rlx! how i am having trouble to insert upperthread on the table! 

Insert table
(defun insert_table (lst pct / tab row col ht i n space)
  (setq space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
        ht  (/ 2.5 (cond ((getvar 'cannoscalevalue)) (1.0)))
        pct (trans pct 1 0)
        n   (trans '(1 0 0) 1 0 T)
		;4 linhas em (+ 4 (length lst)
        tab (setq tab (vla-addtable space (vlax-3d-point pct) (+ 4 (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 (mapcar '(lambda (a) (strcat "Col" (itoa (1+ (vl-position a (car lst)))))) (car lst)) 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 '("TITLE") 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 (if (numberp c) (rtos c) (vl-princ-to-string c)))
				  (setq col (1+ col))
				  )
			(setq row (1+ row))	
		)
	
	
	
  )
  
    
(Princ))

 

Link to comment
Share on other sites
PedroSoa Apprentice

PedroSoa

Posted
  • Author
Posted (edited) 

; Select lines, line lenght , seam type and seam density calculation

(defun C:LENGTHSEAMCAL ( / *error* acdoc ss p i e a d l) (vl-load-com)
  (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark acdoc)
  
  
;Rotina erro
  (defun *error* (msg)
		(and
		  msg
		  (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*,*EXIT*"))
		  (princ (strcat "\nError: " msg))
		)
    (if
      (= 8 (logand (getvar 'undoctl) 8))
      (vla-endundomark acdoc)
    )
    (princ)
    )
 
  
 ;Select lines
 
  (if
    (and
      (setq ss (ssget ":L" '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE"))))
      (setq p (getpoint "\nTable scale depend on annotation scale.\nSpecify table insert point: "))
	  	 )	  
    (progn
      (repeat
        (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i)))
              a (cdr (assoc 8 (entget e)))
              d (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
        )        
		(if
          (setq o (assoc a l))
          (setq l (subst (list a (+ (cadr o) d)) o l))
          (setq l (cons (list a d) l))
        )
      )

	  (setq l (vl-sort l '(lambda (a b) (< (car a) (car b)))))
	      
;;Call Seam
		(setq ln (+ (cadr o) d))
		(seam ln)

      
	  
      (insert_table l p)
	  
      )
    )
  (*error* nil)
  (princ)
  )
  
  
  
;Insert table

(defun insert_table (lst pct / tab row col ht i n space)
	(setq space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
        ht  (/ 2.5 (cond ((getvar 'cannoscalevalue)) (1.0)))
        pct (trans pct 1 0)
        n   (trans '(1 0 0) 1 0 T)
		;4 linhas em (+ 4 (length lst)
        tab (setq tab (vla-addtable space (vlax-3d-point pct) (+ 4 (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)
  )
  
; adjust columns

  (vla-put-HorzCellMargin tab (* 0.14 ht))
  (vla-put-VertCellMargin tab (* 0.14 ht))

  (setq lst (cons (mapcar '(lambda (a) (strcat "Col" (itoa (1+ (vl-position a (car lst)))))) (car lst))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 '("Total Lenght / Upper Thread & Lower Thread") lst))
  
; adjust rows 
 
		(setq row 0)
		(foreach r lst
			(setq col 0 )
			(vla-SetRowHeight tab row (* 1.5 ht))
				(foreach c r
				  (vla-SetText tab row col(if (numberp c) (rtos c) (vl-princ-to-string c)))				  
				  (setq col (1+ col))
				  )
			(setq row (1+ row))
			
			
		)
)
  
  
  
;;Rotina SEAM (TYPE & Stich Density)

	(defun seam (ln)
	(setq st 0)
	
	;SEAM TYPE 
	(while (not (or (= st 301) (= st 401))) 
		  (setq st (getint "\nEnter Seam Type: "))
	  )	  
	(princ st)
	  
	;Stich density
	(setq sd (getint "\nEnter Stitch Density: "))
	(princ sd)
	;Upper and Lowe Thread calculation
	
		(if (= st 301)
			(progn (setq upper (* 1.2 (* ln (+ 1 (/ 13.5 sd )))))
		;(princ upper)
			(setq lower (* 0.8 (* ln (+ 1 (/ 13.5 sd )))))
		;(princ lower)
			)	
		)	
		
		(if (= st 401)    
			(progn (setq upper (* ln (+ 1 (/ 26.5 sd ))))	
		;(princ upper)
			(setq lower (* ln (+ 1 (/ 13.5 sd ))))
		;(princ lower)
			)
		)
  
  
    
(Princ))
;;

image.png.23d69c45ae29973a4477d66e9bed7319.png

Edited by PedroSoa
normally i chose seam 301 and 24 density!  
Link to comment
Share on other sites
rlx Veteran

rlx

Posted
Posted

still not sure what your program is actually used for , calculate length of sewing thread or something? anywayz maybe this is what you mean? 


;;; Insert table
(defun insert_table ( lst pct / tab row col ht i n space )
  (setq space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
        ht (/ 2.5 (cond ((getvar 'cannoscalevalue)) (1.0))) pct (trans pct 1 0) n (trans '(1 0 0) 1 0 T)
        ;;; 4 linhas em (+ 4 (length lst)
        tab (setq tab (vla-addtable space (vlax-3d-point pct) (+ 4 (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))
  ;;; adjust columns
  (vla-put-HorzCellMargin tab (* 0.14 ht))(vla-put-VertCellMargin tab (* 0.14 ht))
  (setq lst (cons (mapcar '(lambda (a)(strcat "Col" (itoa (1+ (vl-position a (car lst))))))(car lst)) 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 '("Total Lenght / Upper Thread & Lower Thread") lst))
  ;;; add upper & lower tread to list
  (setq lst (append lst (list (list "Upper Thread" upper) (list "Lower Thread" lower))))
  ;;; adjust rows
  (setq row 0)
  (foreach r lst
    (setq col 0) (vla-SetRowHeight tab row (* 1.5 ht))
    (foreach c r (vla-SetText tab row col (if (numberp c) (rtos c)(vl-princ-to-string c)))(setq col (1+ col)))
    (setq row (1+ row))
  )
)

 

I just use append command to add two rows to your list (at the back of your list)

  


….

;;; add upper & lower tread to list
  (setq lst (append lst (list (list "Upper Thread" upper) (list "Lower Thread" lower))))

….

 

it would be nice when asking for seam type and stitch density to include the options like :

"\nEnter Seam Type (301 or 401) : " and for density  "\nEnter Stitch Density (1-10) : " or something

 

Link to comment
Share on other sites
PedroSoa Apprentice

PedroSoa

Posted
  • Author
Posted (edited)

yes! perfect ! thank you very much!

 

it should ask! seam type and seam density!  i will take care of it! its for total lenght calculation and in function of the kind of seam calculate the thread (upper and lower) . 

 

awesome! obrigado.

Edited by PedroSoa
one question! can i take the zero from the table and add lenght ?!
Link to comment
Share on other sites
rlx Veteran

rlx

Posted
Posted

replace 

(setq lst (cons '("Total Length / Upper Thread & Lower Thread") lst))
  ;;; add upper & lower tread to list
  (setq lst (append lst (list (list "Upper Thread" upper) (list "Lower Thread" lower))))

with 

(setq lst (vl-remove nil (list '("Total Length / Upper Thread & Lower Thread") (car lst)
    (list "Length" (cadadr lst)) (cddr lst) (list "Upper Thread" upper) (list "Lower Thread" lower))))

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.

×
 Share
Go to topic listing
×
×
  • Create New...