Insert in simultaneous the dimensions of the lengths of the segments of a polyline

[teknomatika]

I'm not sure, but I think I've seen around here a routine similar to PLEN.LSP (authored by master Lee Mac), but able to automatically annotate the lengths of all segments of a polyline, as I show in the attached image.

 

I appreciate the help if anyone know.

[Tharwat]

Old one of mine ...

 

(defun c:Test (/ *error* pl i sn)
 (vl-load-com)
 (defun *error* (msg)
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **")))
   (princ)
   )
 (cond ((not acdoc) (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))))
 (princ "\n select a Polyline :")
 (if (setq pl (ssget '((0 . "*POLYLINE"))))
   (progn (vla-StartUndoMark acdoc)
          (repeat (setq i (sslength pl)) (setq sn (ssname pl (setq i (1- i)))) (WriteLengthsForSegments sn))
          (vla-EndUndoMark acdoc)
          )
   (princ)
   )
 (princ "\n Written By Tharwat Al Shoufi")
 (princ)
 )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun WriteLengthsForSegments (sn / j a b sty txt)
 (progn (setq j 0)
        (repeat (fix (vlax-curve-getendparam sn))
          (setq a (vlax-curve-getpointatparam sn j))
          (setq b (vlax-curve-getpointatparam sn (setq j (1+ j))))
          (setq
            txt (entmakex
                  (list '(0 . "MTEXT")
                        '(100 . "AcDbEntity")
                        '(100 . "AcDbMText")
                        (assoc 8 (entget sn))
                        (cons 10 (mapcar '(lambda (x y) (/ (+ y x) 2.)) a b))
                        (cons 7 (getvar 'textstyle))
                        (cons 40
                              (if (eq (cdr (assoc 40 (setq sty (entget (tblobjname "style" (getvar 'textstyle)))))) 0.)
                                (cdr (assoc 42 sty))
                                (cdr (assoc 40 sty))
                                )
                              )
                        (cons 1 (rtos (distance a b) 2))
                        (cons 50 (angle a b))
                        '(71 . 5)
                        )
                  )
            )
          (vla-put-BackgroundFill (vlax-ename->vla-object txt) -1)
          )
        )
 )

[teknomatika]

Tharwat,

 

That's it. Fantastic. :)But it will be possible to reprogram to allow the placement of text, using an option, may have a certain offset outside or inside?

[Tharwat]

Tharwat,

 

That's it. Fantastic. :)But it will be possible to reprogram to allow the placement of text, using an option, may have a certain offset outside or inside?

 

You're welcome .

 

Give this a shot .

 

(defun c:Test (/ *error* WriteLengthsForSegments pl i dir)
 (vl-load-com)
 ;;; Tharwat 12. Sep. 2012 ;;;
 (if (not acdoc)
   (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
 )
 (defun *error* (msg)
   (vla-EndUndoMark acdoc)
   (princ "\n *Cancel*")
   (princ)
 )

 (defun WriteLengthsForSegments (sn dir / h j a b sty)
   (progn (setq j 0)
          (repeat (fix (vlax-curve-getendparam sn))
            (setq a (vlax-curve-getpointatparam sn j))
            (setq b (vlax-curve-getpointatparam sn (setq j (1+ j))))
            (entmakex
              (list
                '(0 . "MTEXT")
                '(100 . "AcDbEntity")
                '(100 . "AcDbMText")
                (assoc 8 (entget sn))
                (cons 7 (getvar 'textstyle))
                (cons
                  40
                  (setq h
                         (if
                           (eq (cdr (assoc 40
                                           (setq sty (entget (tblobjname
                                                               "style"
                                                               (getvar 'textstyle)
                                                             )
                                                     )
                                           )
                                    )
                               )
                               0.
                           )
                            (cdr (assoc 42 sty))
                            (cdr (assoc 40 sty))
                         )
                  )
                )

                (cons 10
                      (polar (mapcar '(lambda (x y) (/ (+ y x) 2.)) a b)
                             (if (eq dir "Out")
                               (+ (angle a b) (* pi 0.5))
                               (+ (angle b a) (* pi 0.5))
                             )
                             (* h 1.1)
                      )
                )

                (cons 1 (rtos (distance a b) 2))
                (cons 50 (angle a b))
                '(71 . 5)
              )
            )
          )
   )
   (princ)
 )
 (princ "\n select a Polyline :")
 (if (and (setq pl (ssget '((0 . "*POLYLINE"))))
          (progn (initget "In Out")
                 (setq dir
                        (cond
                          ((getkword "\n Specify Text placement [in/Out] <Out> :")
                          )
                          (t "Out")
                        )
                 )
          )
     )
   (progn (vla-StartUndoMark acdoc)
          (repeat (setq i (sslength pl))
            (WriteLengthsForSegments (ssname pl (setq i (1- i))) dir)
          )
          (vla-EndUndoMark acdoc)
   )
   (princ)
 )
 (princ "\n Written By Tharwat Al Shoufi")
 (princ)
)

[teknomatika]

Tharwat,

 

Perfect! Thanks for the help!

[Tharwat]

Tharwat,

 

Perfect! Thanks for the help!

 

You're welcome anytime .