Monday 18 February 2013

Polyline Measurments



Info : Creates Distance Text  to Selected Polylines , Lwpolyline and Line

(defun c:mse (/ *error* adoc space sset i ang e en p s nd _Text c pp p1
       p2)
    (vl-load-com)
    (defun *error* (x)
 (if adoc
     (vla-endundomark adoc)
 )
 (cond ((not x))
       ((member x '("Function cancelled" "quit / exit abort")))
       ((princ (strcat "\n----> Error:" x)))
 )
 (princ)
    )
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    (setq space (vla-get-modelspace adoc))
    (vla-startundomark adoc)
    (prompt "\nSelect LINE,POLYLINES,LWPOLYLINES")
    (if (setq sset (ssget "_:L"
     '((-4 . "<Or")
       (0 . "LINE")
       (0 . "LWPOLYLINE")
       (0 . "POLYLINE")
       (-4 . "Or>")
      )
     )
 )
 (progn
     (defun ang (a b / ang1)
  (setq ang1 (atof (angtos (angle a b))))
  (if
      (and
   (>= ang1 90.0)
   (<= ang1 273.0)
      )
         (angle b a)
         (angle a b)
  )
     )

      (repeat (setq i (sslength sset))
  (setq e (ssname sset (setq i (1- i))))
  (setq en (entget e))
  (if (= "LINE" (cdr (assoc 0 en)))
      (progn (setq s (cdr (assoc 10 en)))
      (setq nd (cdr (assoc 11 en)))
      (setq p  (mapcar
     (function (lambda (a b) (/ (+ a b) 2.))
     )
     s
     nd
        )
      )
      (setq _Text (vla-addtext
        space
        (rtos (distance s nd))
        (vlax-3d-point p)
        2.0
           )
      )
      (vla-put-alignment
          _Text
          acalignmentbottomcenter
      )
      (vla-put-TextAlignMentPoint
          _Text
          (vlax-3d-point p)
      )
      (vla-put-Rotation _Text (ang s nd))
      )
      (progn (setq c 0)
      (repeat (- (fix (vlax-curve-getendparam e))
          (fix (vlax-curve-getstartparam e))
       )
          (setq pp (mapcar
         (function
      (lambda (a b) (/ (+ a b) 2.))
         )
         (setq p1 (vlax-curve-getpointatparam
        e
        c
           )
         )
         (setq p2 (vlax-curve-getpointatparam
        e
        (setq c (1+ c))
           )
         )
     )
          )

           (setq _Text (vla-addtext
            space
            (rtos (distance p1 p2))
            (vlax-3d-point pp)
            2.0
        )
          )
          (vla-put-alignment
       _Text
       acalignmentbottomcenter
          )
          (vla-put-TextAlignMentPoint
       _Text
       (vlax-3d-point pp)
          )
          (vla-put-Rotation _Text (ang p1 p2))
      )
      )
  )
     )
 )
    )
    (*error* nil)
    (vla-endundomark adoc)
    (vlax-release-object adoc)
    (princ)
)

0 comments:

Post a Comment