Jump to content

Measure distance between two intersection points


nguyenkaca

Recommended Posts

Hi every body,

I'm new to this forum and know very little about programming lisp routine.I usually just come across ones every now and then and add them to my installation of AutoCAD 2007.

Does anyone know of a routine that would be able to measure distance between two intersection points.

Sample:

Drawing1.dwg

Please help me.I really need it because it take me a lot of time to do this.

Thank for any and all help.

KaCa

Link to comment
Share on other sites

  • Replies 22
  • Created
  • Last Reply

Top Posters In This Topic

  • nguyenkaca

    10

  • pBe

    5

  • ketxu

    3

  • Tiger

    2

Top Posters In This Topic

I'm currently thinking how to go about it in one go. have you look at the links below

. may be you can find one that suit your needs. it will cut the your waiting time in half.

------||------

------||------

----- \ /------

------\/-------

 

 

BTW: Welcome to the forum :)

Link to comment
Share on other sites

That's great.

But it's easy to make a mistake because it hasn't got any arrows to show distance between two intersection points.so when i give my drawing to my worker they will make a mistake.

Link to comment
Share on other sites

Quick change a little from of LM rountine to suite with Kaca' request. I hope LM don't mind :( . I've mark what changed

;;-------------=={ Length Between Intersections }==-----------;;
;;                                                            ;;
;;  Displays the length of segments of a curve divided at     ;;
;;  intersections with other objects.                         ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Version 1.4    -    26-04-2011                            ;;
;;------------------------------------------------------------;;

(defun c:IntLen ( / *error* _iscurveobject e )

 (defun *error* ( msg )
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )

 (defun _IsCurveObject ( entity / param )
   (and
     (not
       (vl-catch-all-error-p
         (setq param
           (vl-catch-all-apply 'vlax-curve-getendparam (list entity))
         )
       )
     )
     param
   )
 )

 (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar 'CLAYER))))))
   (princ "\n--> Current Layer Locked.")  
   (while
     (progn (setvar 'ERRNO 0) (setq e (car (entsel)))
       (cond
         (
           (= 7 (getvar 'ERRNO))

           (princ "\n--> Missed, Try again.")
         )
         (
           (eq 'ENAME (type e))

           (if (_iscurveobject e)
             (LM:IntersectionLengths e)
             (princ "\n--> Invalid Object Selected.")
           )
           t
         )
       )
     )
   )
 )
 (princ)
)

;;------------------------------------------------------------;;

(defun c:IntLenM ( / *error* ss i )

 (defun *error* ( msg )
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )

 (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar 'CLAYER))))))
   (princ "\n--> Current Layer Locked.")
   (if (setq ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE"))))
     (repeat (setq i (sslength ss))
       (LM:IntersectionLengths (ssname ss (setq i (1- i))))
     )
   )
 )

 (princ)
)

;;------------------------------------------------------------;;

(defun LM:IntersectionLengths

 ( e  ;; Entity name
   
   / *error* _startundo _endundo _groupbynum _sortbyparam _makereadable _isannotative _uniquefuzz
     a acspc c d d1 d2 da e i l ll m o ss ta to ts ur x y
 )

 (setq acdoc (cond ( acdoc ) ( (vla-get-activedocument (vlax-get-acad-object)) ))
       acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace))
 )

 (defun *error* ( msg )
   (if acdoc (_EndUndo acdoc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )

 (defun _StartUndo ( doc ) (_EndUndo doc)
   (vla-StartUndoMark doc)
 )

 (defun _EndUndo ( doc )
   (if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-EndUndoMark doc))
 )

 (defun _GroupByNum ( l n / r)
   (if l
     (cons
       (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r))
       (_GroupByNum l n)
     )
   )
 )

 (defun _SortbyParam ( e l )
   (vl-sort l '(lambda ( a b ) (< (vlax-curve-getParamatPoint e a) (vlax-curve-getParamatPoint e b))))
 )

 (defun _MakeReadable ( a )
   (
     (lambda ( a )
       (cond
         ( (and (> a (/ pi 2)) (<= a pi))

           (- a pi)
         )
         ( (and (> a pi) (<= a (/ (* 3 pi) 2)))

           (+ a pi)
         )
         ( a )
       )
     )
     (rem a (* 2 pi))
   )
 )

 (defun _isAnnotative ( style / object annotx )
   (and
     (setq object (tblobjname "STYLE" style))
     (setq annotx (cadr (assoc -3 (entget object '("AcadAnnotative")))))
     (= 1 (cdr (assoc 1070 (reverse annotx))))
   )
 )

 (defun _uniquefuzz ( lst fuzz )
   (if lst
     (cons (car lst)
       (_uniquefuzz
         (vl-remove-if '(lambda ( x ) (equal x (car lst) fuzz)) (cdr lst)) fuzz
       )
     )
   )
 )

 (setq ts
   (/ (getvar 'textsize)
     (if (_isAnnotative (getvar 'textstyle))
       (cond ( (getvar 'cannoscalevalue) ) ( 1.0 )) 1.0
     )
   )
 )

 (_StartUndo acdoc)
 
 (vla-getBoundingBox (setq o (vlax-ename->vla-object e)) 'll 'ur)

 (mapcar '(lambda ( x ) (set x (vlax-safearray->list (eval x)))) '(ll ur))

 (if
   (setq l
     (_sortbyparam e
       (_uniquefuzz
         (apply 'append
           (repeat
             (setq i
               (sslength
                 (ssdel e
                   (setq ss
                     (ssget "_C" (trans ur 0 1) (trans ll 0 1) '((0 . "ARC,CIRCLE,ELLIPSE,*LINE")))
                   )
                 )
               )
             )
             (setq l
               (cons
                 (_groupbynum
                   (vlax-invoke o 'intersectwith
                     (vlax-ename->vla-object (ssname ss (setq i (1- i)))) acextendnone
                   )
                   3
                 )
                 l
               )
             )
           )
         )
         1e-8
       )
     )
   )
   (if (not (vlax-curve-isClosed e))
     (progn
       (or
         (equal (vlax-curve-getStartParam e) (vlax-curve-getParamatPoint e (car l)) 0.001)
         (setq l (cons (vlax-curve-getStartPoint e) l))
       )
       (or
         (equal (vlax-curve-getEndParam e) (vlax-curve-getParamatPoint e (last l)) 0.001)
         (setq l (append l (list (vlax-curve-getEndPoint e))))
       )
     )
     (setq c l)
   )
   (if (vlax-curve-isClosed e)
     (setq l (list (vlax-curve-getStartPoint e)) c l)
     (setq l (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e)))
   )
 )

 (while (cadr l) (setq x (car l) y (cadr l) l (cdr l))
   (setq m
     (vlax-curve-getPointatDist e
       (/ (+ (vlax-curve-getDistatPoint e y) (vlax-curve-getDistAtPoint e x)) 2.)
     )
   )
   [color=mediumturquoise];(setq d
   ;  (abs
   ;    (- (vlax-curve-getDistatPoint e y) (vlax-curve-getDistAtPoint e x))
   ;  )
   
   ;(setq a
   ;  (angle '(0. 0. 0.)
   ;    (vlax-curve-getFirstDeriv e (vlax-curve-getParamatPoint e m))
   ;  )
   
   ;(setq ta (_makereadable a))

   ;(setq to (vla-AddText acspc (rtos d) (vlax-3D-point '(0. 0. 0.)) ts))
   ;(vla-put-Alignment to acAlignmentMiddleCenter)
   ;(vla-put-TextAlignmentPoint to (vlax-3D-point (polar m (+ ta (/ pi 2.)) (* 1.1 ts))))
   ;(vla-put-rotation to ta)[/color]
   [color=red](vla-AddDimAligned acspc (vlax-3D-point x) (vlax-3D-point y) (vlax-3D-point m))[/color]
 )
 
 (if (vlax-curve-isclosed e)
   (progn
     (if (= 1 (length c)) (setq c (append c c)))
     (setq d
       (+
         (setq d1 (vlax-curve-getDistatPoint e (car c)))
         (setq d2 (- (vlax-curve-getdistatparam e (vlax-curve-getendparam e)) (vlax-curve-getdistatpoint e (last c))))
       )
     )                  
     (setq m
       (vlax-curve-getPointatDist e
         (if (< d1 (setq da (/ (+ d1 d2) 2.)))
           (setq da (- (vlax-curve-getdistatparam e (vlax-curve-getendparam e)) (- da d1)))
           (setq da (- da d2))
         )
       )
     )
     (setq a
       (angle '(0. 0. 0.)
         (vlax-curve-getFirstDeriv e (vlax-curve-getParamatPoint e m))
       )
     )
     (setq ta (_makereadable a))

     (setq to (vla-AddText acspc (rtos d) (vlax-3D-point '(0. 0. 0.)) ts))
     (vla-put-Alignment to acAlignmentMiddleCenter)
     (vla-put-TextAlignmentPoint to (vlax-3D-point (polar m (+ ta (/ pi 2.)) (* 1.1 ts))))
     (vla-put-rotation to ta)
   )
 )

 (_EndUndo acdoc)
 (princ)
)

;;------------------------------------------------------------;;

(vl-load-com)
(princ)
(princ "\n:: IntLen.lsp | Version 1.4 | © Lee Mac 2011 www.lee-mac.com ::")
(princ "\n:: Type \"IntLen\" or \"IntLenM\" to Invoke ::")
(princ)

;;------------------------------------------------------------;;
;;                         End of File                        ;;
;;------------------------------------------------------------;;

@Nguyenkaca : chịu khó đi hỏi hè. Cadtutor đòi hỏi bạn phải trình bày vấn đề một cách rõ ràng và cụ thể các trường hợp :)

Link to comment
Share on other sites

The code is great.But i only select one object per time. Could you help me improve it. Let me can select all object.

Don't u see prompt line to use Intlen and Use IntlenM ? Just use IntlenM to multi work

oh i want to say thank every body
Ketxu, you are vietnamese?

Ừm, mình là người Việt nam !

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.


×
×
  • Create New...