Add Attribute blocks to every polyline corners

[E.S.7.9]

hi

I have 3 different lisp to use them for what I want to do , I tried to combine them as a one lisp  but I am not a good programmer and that is why it has been unsuccessfully attempt

So , if can any body help me , here is what process that I need in lisp routine ;

I attached image file , as you can see  what I need to do is inserting attribute block to every corner of my multiple corners polyline …

this can work for me but it would be much better if routine could boost +1 to corner numbers in "Corner.No" tags and put the distance between 2 points length value to "Distance Value" tag

thank you for your help 

[ВeekeeCZ · Accepted solution]

How about post the drawing and sample block? /next time/

Try this code... change the name of the block, you may add the file path as you like.

Spoiler

(vl-load-com)

(defun c:CornerLabel ( / *error* nVAR oVAR adoc :AddLeadingZeros ss en n m pt ds pt)
  
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
      (princ (strcat "\nError: " errmsg)))
    (mapcar 'setvar nVAR oVAR)
    (vla-endundomark adoc)
    (princ))
  
  (defun :AddLeadingZeros (a d / b) ;add zeros to 'd' many digits  ;a string
    (strcat (substr "000000000" 1 (if (>= d (setq b (strlen (itoa (fix (atof a)))))) (- d b) 0)) a))
  
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (setq oVAR (mapcar 'getvar (setq nVAR '(ATTREQ ATTDIA))))
  (mapcar 'setvar nVAR 			'(1	 0))
  
  (if (setq ss (ssget  "_+.:E:S" '((0 . "LWPOLYLINE"))))
    (repeat (setq i (sslength ss))
      (setq en (ssname ss (setq i (1- i)))
	    n -1
	    m (vlax-curve-getEndParam en))
      (while (<= (setq n (1+ n)) m)
	(setq pt (vlax-curve-getPointAtParam en n)
	      ds (vlax-curve-getDistAtParam en n))
	(vl-cmdf "_.INSERT" "CORNER" "_S" 1 "_R" 0  		; change NAME, may add the path. don't forget use /
		 "_none" pt
		 (strcat "CN-" (:AddLeadingZeros (itoa n) 2))
		 (strcat (rtos ds 2 0) " mm")
		 ))))
  (*error* "end")
)

[E.S.7.9]

bingo ... Thank you so much

[pbejse]

Try this

(defun c:demo ( / s e p l i bl)
(setq spc (vlax-get (vla-get-ActiveLayout
(vla-get-activedocument (vlax-get-acad-object)))
'Block))
(if (setq s (ssget "_:S" '((0 . "LWPOLYLINE"))))
(progn
(setq i 0 e (ssname s 0))
(setq p (vlax-curve-getEndParam e))
(repeat (setq p (1+ (fix p)))
(setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l)))
(setq dist (mapcar '(lambda (j)(vlax-curve-getDistAtPoint e j)) l))
(mapcar '(lambda (a b) (setq bl (vlax-invoke spc 'InsertBlock a "Corner.No" 1 1 1 0))
(mapcar '(lambda ( c d )
(vla-put-textstring c d))
(vlax-invoke bl 'GetAttributes)
(list (strcat "CN-" (if (< (setq i (1+ i)) 10) "0" "") (itoa i))
(strcat (rtos b 2 2) " mm"))
)
)
l (cons 0.0 (mapcar '(lambda ( n m ) (- n m)) (cdr dist) dist ))
)
)
)
(princ)
)

[pbejse]

BeekeeCZ

It appears that the code you posted shows not the distance between points but of distance at that point, not sure though but that is what i understand from the image from the OP

 Theres something weird happening with my browser, cant even see the code tags

what gives?

[ВeekeeCZ]

---

@pbejse wrote:

BeekeeCZ

It appears that the code you posted shows not the distance between points but of distance at that point, not sure though but that is what i understand from the image from the OP

...

---

Ohh, you're right. Simple to fix. Thanks for the heads up!

Spoiler

(vl-load-com)

(defun c:CornerLabel ( / *error* nVAR oVAR adoc :AddLeadingZeros ss en n m pt ds pt)
  
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
      (princ (strcat "\nError: " errmsg)))
    (mapcar 'setvar nVAR oVAR)
    (vla-endundomark adoc)
    (princ))
  
  (defun :AddLeadingZeros (a d / b) ;add zeros to 'd' many digits  ;a string
    (strcat (substr "000000000" 1 (if (>= d (setq b (strlen (itoa (fix (atof a)))))) (- d b) 0)) a))
  
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (setq oVAR (mapcar 'getvar (setq nVAR '(ATTREQ ATTDIA))))
  (mapcar 'setvar nVAR 			'(1	 0))
  
  (if (setq ss (ssget  "_+.:E:S" '((0 . "LWPOLYLINE"))))
    (repeat (setq i (sslength ss))
      (setq en (ssname ss (setq i (1- i)))
	    n -1
	    m (vlax-curve-getEndParam en))
      (while (<= (setq n (1+ n)) m)
	(setq pt (vlax-curve-getPointAtParam en n)
	      ds (- (vlax-curve-getDistAtParam en n)
		    (vlax-curve-getDistAtParam en (max (1- n) 0))))
	(vl-cmdf "_.INSERT" "CORNER" "_S" 1 "_R" 0  		; change NAME, may add the path. don't forget use /
		 "_none" pt
		 (strcat "CN-" (:AddLeadingZeros (itoa n) 2))
		 (strcat (rtos ds 2 0) " mm")
		 ))))
  (*error* "end")
)

[pbejse · Accepted solution]

Wish there was a way to modify previous post to fix the format or "update" a code tags [Wish List]

Anyways....  modified to remove decimal points, also  print Individual and Total distance on command prompt

(defun c:demo (/ r s e p l i bl dist)
  (setq spc	(vlax-get (vla-get-ActiveLayout
		    (vla-get-activedocument (vlax-get-acad-object))
		  )
		  'Block
	)
  )
  (if (setq s (ssget "_:S" '((0 . "LWPOLYLINE"))))
    (progn
      (setq i 0  e (ssname s 0) )
      (setq p (vlax-curve-getEndParam e))
      (repeat (setq p (1+ (fix p)))
	(setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
      )
      (setq dist (mapcar '(lambda (j) (vlax-curve-getDistAtPoint e j)) l)
      )
      (mapcar '(lambda (a b)
		 (setq  bl (vlax-invoke spc 'InsertBlock a "kokoy" 1 1 1 0))
		 (setq r (cons (list (strcat "CN-"
				       (if (< (setq i (1+ i)) 10) "0" "" )
				       (itoa i)
			       )
			       (strcat (rtos b 2 0) " mm")
			 )	r	))
		 (mapcar '(lambda (c d)
			    (vla-put-textstring c d)
			  )
			 (vlax-invoke bl 'GetAttributes)
			 (car r)
		 )
	       )
	      l
	      (cons 0.0 (mapcar '(lambda (n m) (- n m)) (cdr dist) dist))
      )
      (princ (apply 'strcat
		      (Mapcar '(lambda (x)
				 (Strcat (car x) " | " (cadr x) "\n")
			       )
			      (reverse (cons  (list "Total" (strcat  (rtos (last dist) 2 0) " mm")) r))
		      )
	       )
	)
    )
  )
  (princ)
)

Command: DEMO
Select objects:
CN-01 | 0 mm
CN-02 | 1500 mm
CN-03 | 7500 mm

CN-04 | 1000 mm

...

...

CN-25 | 1250 mm
Total | 25500 mm

HTH