List for auto-numbering and length

[lucky9]

Hi, I'm new to this forum and Autocad lisp, I find the following code from about 7 year old (2010) thread.

I started new thread as I don't know if bumping old thread is welcomed or not, most of the times bumping old threads are fawned upon on most forums.

 

Now, lets get to the point,

 

Source Code: Thread 21st Apr 2010 02:15 pm

 

(defun c:PLab (/ obj)
 ;; Label each LWPolyline segment with number and distance
 ;; Alan J. Thompson, 04.21.10
 (if (and (setq obj (car (entsel "\nSelect LWPolyline: ")))
          (or (eq "LWPOLYLINE" (cdr (assoc 0 (entget obj))))
              (alert "Invalid object!")
          )
          (setq obj (vlax-ename->vla-object obj))
     )
   ((lambda (n l / a b)
      (while (nth (1+ (setq n (1+ n))) l)
        (progn
          (vla-put-rotation
            (AT:MText (vlax-3d-point
                        (vlax-curve-GetClosestPointTo
                          obj
                          (mapcar (function (lambda (x y) (/ (+ x y) 2.)))
                                  (setq a (nth n l))
                                  (setq b (nth (1+ n) l))
                          )
                        )
                      )
                      (strcat (itoa (1+ n))
                              " - "
                              (rtos (abs (- (vlax-curve-getDistAtPoint obj a)
                                            (vlax-curve-getDistAtPoint obj b)
                                         )
                                    )
                              )
                      )
                      0.
                      nil
                      8
            )
            (angle a b)
          )
        )
      )
    )
     -1
     (AT:ListGroupByNumber (vlax-get obj 'Coordinates) 2)
   )
 )
 (princ)
)


;;; Add MText to drawing
;;; Pt - MText insertion point
;;; Str - String to place in created MText object
;;; Wd - Width of MText object (if nil, will be 0 width)
;;; Lay - Layer to place Mtext object on (nil for current)
;;; Jus - Justification # for Mtext object
;;;       1 or nil= TopLeft
;;;       2= TopCenter
;;;       3= TopRight
;;;       4= MiddleLeft
;;;       5= MiddleCenter
;;;       6= MiddleRight
;;;       7= BottomLeft
;;;       8= BottomCenter
;;;       9= BottomRight
;;; Alan J. Thompson, 05.23.09 / 04.09.10
(defun AT:MText (Pt Str Wd Lay Jus / Wd s o)
 (or Wd (setq Wd 0.))
 (setq s  (if (or (eq acmodelspace
                      (vla-get-activespace
                        (cond (*AcadDoc*)
                              ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
                        )
                      )
                  )
                  (eq :vlax-true (vla-get-mspace *AcadDoc*))
              )
            (vla-get-modelspace *AcadDoc*)
            (vla-get-paperspace *AcadDoc*)
          )
       Pt (cond ((vl-consp Pt) (vlax-3d-point Pt))
                ((eq (type Pt) 'variant) Pt)
          )
 )
 (setq o (vla-addMText s Pt Wd (vl-princ-to-string Str)))
 (and Lay (tblsearch "layer" Lay) (vla-put-layer o Lay))
 (cond ((vl-position Jus '(1 2 3 4 5 6 7 8 9))
        (vla-put-AttachmentPoint o Jus)
        (vla-put-InsertionPoint o Pt)
       )
 )
 o
)



;;; Group items in list based on specified number
;;; L - List to process
;;; # - Number of items for grouping
;;; Alan J. Thompson, 03.26.10
(defun AT:ListGroupByNumber (L # / n g f)
 (setq n -1)
 (while (> (1- (length L)) n)
   (repeat # (setq g (cons (nth (setq n (1+ n)) L) g)))
   (setq f (cons (reverse g) f)
         g nil
   ) ;_ setq
 ) ;_ while
 (reverse f)
) ;_ defun

 

 

This above code is pretty good of what it does and what I was looking for. But here is a twist. It's placing text upside down in the following scenario: please have a look at the image attached here..

If anyone can please fix the lip would be highly appreciated.

 

Thanks:)

 

 

 

 

[ronjonp]

Try this .. I included Alan's 'at:makereadable' function.

 

(defun c:plab (/ obj)
 ;; Label each LWPolyline segment with number and distance
 ;; Alan J. Thompson, 04.21.10
 (if (and (setq obj (car (entsel "\nSelect LWPolyline: ")))
   (or (eq "LWPOLYLINE" (cdr (assoc 0 (entget obj)))) (alert "Invalid object!"))
   (setq obj (vlax-ename->vla-object obj))
     )
   ((lambda (n l / a b)
      (while (nth (1+ (setq n (1+ n))) l)
 (progn
   (vla-put-rotation
     (at:mtext
       (vlax-3d-point
	 (vlax-curve-getclosestpointto
	   obj
	   (mapcar (function (lambda (x y) (/ (+ x y) 2.)))
		   (setq a (nth n l))
		   (setq b (nth (1+ n) l))
	   )
	 )
       )
       (strcat
	 (itoa (1+ n))
	 " - "
	 (rtos (abs (- (vlax-curve-getdistatpoint obj a) (vlax-curve-getdistatpoint obj b)))
	 )
       )
       0.
       nil
       8
     )
     (at:makereadable (angle a b))
   )
 )
      )
    )
     -1
     (at:listgroupbynumber (vlax-get obj 'coordinates) 2)
   )
 )
 (princ)
)


;;; Add MText to drawing
;;; Pt - MText insertion point
;;; Str - String to place in created MText object
;;; Wd - Width of MText object (if nil, will be 0 width)
;;; Lay - Layer to place Mtext object on (nil for current)
;;; Jus - Justification # for Mtext object
;;;       1 or nil= TopLeft
;;;       2= TopCenter
;;;       3= TopRight
;;;       4= MiddleLeft
;;;       5= MiddleCenter
;;;       6= MiddleRight
;;;       7= BottomLeft
;;;       8= BottomCenter
;;;       9= BottomRight
;;; Alan J. Thompson, 05.23.09 / 04.09.10
(defun at:mtext	(pt str wd lay jus / wd s o)
 (or wd (setq wd 0.))
 (setq	s  (if (or (eq acmodelspace
	       (vla-get-activespace
		 (cond (*acaddoc*)
		       ((setq *acaddoc* (vla-get-activedocument (vlax-get-acad-object))))
		 )
	       )
	   )
	   (eq :vlax-true (vla-get-mspace *acaddoc*))
       )
     (vla-get-modelspace *acaddoc*)
     (vla-get-paperspace *acaddoc*)
   )
pt (cond ((vl-consp pt) (vlax-3d-point pt))
	 ((eq (type pt) 'variant) pt)
   )
 )
 (setq o (vla-addmtext s pt wd (vl-princ-to-string str)))
 (and lay (tblsearch "layer" lay) (vla-put-layer o lay))
 (cond	((vl-position jus '(1 2 3 4 5 6 7 8 9))
 (vla-put-attachmentpoint o jus)
 (vla-put-insertionpoint o pt)
)
 )
 o
)

;;; Group items in list based on specified number
;;; L - List to process
;;; # - Number of items for grouping
;;; Alan J. Thompson, 03.26.10
(defun at:listgroupbynumber (l # / n g f)
 (setq n -1)
 (while (> (1- (length l)) n)
   (repeat # (setq g (cons (nth (setq n (1+ n)) l) g)))
   (setq f (cons (reverse g) f)
  g nil
   ) ;_ setq
 ) ;_ while
 (reverse f)
) ;_ defun

(defun at:makereadable (ang)
 ;; Make angle readable
 ;; Alan J. Thompson, 12.14.10
 (if (and (> ang (/ pi 2.)) (<= ang (* pi 1.5)))
   (+ ang pi)
   ang
 )
)

[NADER-2020]

HI , this is good lisp , but it working for one object . i want to use it for multi object 

[BIGAL]

Do you know anything about lisp in particular using ssget then the repeat function, these would replace the entsel method which is one at a time near the top of the code. So a few lines at top and 1 near end to close the repeat function.

 

[NADER-2020]

i am asking for help because i am not good in lisp, so if u can help me i would grateful to you .

 

 

 

[lucky9]

Im good at vba but i find it difficult to learn lisp programming, i wonder if there is free easy learning tutorial source available whcih covers a to z about autolisp programming would be wonderful. 

[BIGAL]

Here is multiple selection added it is not labelling the last segment not sure why will try to find time to look at it. I know Alan JT is on some forums he may have updated the code.

 

;; Label each LWPolyline segment with number and distance
 ;; Alan J. Thompson, 04.21.10
 
(defun c:plab (/ obj k )
 (if (= (setq ss (ssget (list  (cons 0 "LWPolyline")))) nil)
   (progn  (alert "Invalid objects picked exiting now !")(exit))   
   (repeat (setq K (sslength ss))
      (setq obj (vlax-ename->vla-object (ssname ss (setq k (- k 1)))))
   ((lambda (n l / a b)
      (while (nth (1+ (setq n (1+ n))) l)
 (progn
   (vla-put-rotation
     (at:mtext
       (vlax-3d-point
	 (vlax-curve-getclosestpointto
	   obj
	   (mapcar (function (lambda (x y) (/ (+ x y) 2.)))
		   (setq a (nth n l))
		   (setq b (nth (1+ n) l))
	   )
	 )
       )
       (strcat
	 (itoa (1+ n))
	 " - "
	 (rtos (abs (- (vlax-curve-getdistatpoint obj a) (vlax-curve-getdistatpoint obj b)))
	 )
       )
       0.
       nil
       8
     )
     (at:makereadable (angle a b))
   )
 )
      )
    )
     -1
     (at:listgroupbynumber (vlax-get obj 'coordinates) 2)
   )
 )
 )
 (princ)
)


;;; Add MText to drawing
;;; Pt - MText insertion point
;;; Str - String to place in created MText object
;;; Wd - Width of MText object (if nil, will be 0 width)
;;; Lay - Layer to place Mtext object on (nil for current)
;;; Jus - Justification # for Mtext object
;;;       1 or nil= TopLeft
;;;       2= TopCenter
;;;       3= TopRight
;;;       4= MiddleLeft
;;;       5= MiddleCenter
;;;       6= MiddleRight
;;;       7= BottomLeft
;;;       8= BottomCenter
;;;       9= BottomRight
;;; Alan J. Thompson, 05.23.09 / 04.09.10
(defun at:mtext	(pt str wd lay jus / wd s o)
 (or wd (setq wd 0.))
 (setq	s  (if (or (eq acmodelspace
	       (vla-get-activespace
		 (cond (*acaddoc*)
		       ((setq *acaddoc* (vla-get-activedocument (vlax-get-acad-object))))
		 )
	       )
	   )
	   (eq :vlax-true (vla-get-mspace *acaddoc*))
       )
     (vla-get-modelspace *acaddoc*)
     (vla-get-paperspace *acaddoc*)
   )
pt (cond ((vl-consp pt) (vlax-3d-point pt))
	 ((eq (type pt) 'variant) pt)
   )
 )
 (setq o (vla-addmtext s pt wd (vl-princ-to-string str)))
 (and lay (tblsearch "layer" lay) (vla-put-layer o lay))
 (cond	((vl-position jus '(1 2 3 4 5 6 7 8 9))
 (vla-put-attachmentpoint o jus)
 (vla-put-insertionpoint o pt)
)
 )
 o
)

;;; Group items in list based on specified number
;;; L - List to process
;;; # - Number of items for grouping
;;; Alan J. Thompson, 03.26.10
(defun at:listgroupbynumber (l # / n g f)
 (setq n -1)
 (while (> (1- (length l)) n)
   (repeat # (setq g (cons (nth (setq n (1+ n)) l) g)))
   (setq f (cons (reverse g) f)
  g nil
   ) ;_ setq
 ) ;_ while
 (reverse f)
) ;_ defun


;; Make angle readable
 ;; Alan J. Thompson, 12.14.10
(defun at:makereadable (ang)
  (if (and (> ang (/ pi 2.)) (<= ang (* pi 1.5)))
   (+ ang pi)
   ang
 )
)