Jump to content

Block Distance From Nearest Point on a Polyline


wannabe

Recommended Posts

As the title suggests, I am looking for some kind of automated procedure where i can get a list that details the distance from a block to the nearest point on a line.

 

In more detail, and based on the purpose I need it for, please read the following.

 

Typically we have a railway track or a stretch of highway (either existing or proposed, its not really a consideration for the programme) that has boreholes and trial pits scattered around on either side of the track at arbritrary distances.

 

Now, the engineers are asking me to come up with a way of generating a report that can show how far each borehole or trial pit etc (these will be blocks in the drawing) is located from the nearest point on the track (which will be a 2d or 3d polyline in CAD).

 

If someone can provide this kind of function, I may have other more complex requirements that my company may be willing to compensate some time down the line. There is no guarantee of future work, though. And all I can offer now is my full appreciation.

Link to comment
Share on other sites

  • Replies 65
  • Created
  • Last Reply

Top Posters In This Topic

  • Lee Mac

    33

  • wannabe

    16

  • ASMI

    8

  • SEANT

    5

Top Posters In This Topic

Posted Images

I've managed to find a good example for anyone who wants to have a sniff around.

 

In the attached drawing there is a topo survey, and at the top contains two green lines which are the railway tracks.

 

The red symbols (circular with two triangular hatches) are the boreholes - the blocks whos nearest distance from their center to the railway track we want to measure. These blocks are all on layer: Proposed - Red (as are all of their entities).

 

Ideally, we want a programme that asks us to choose which line we want to measure the blocks from and then have each block measured from its centre to the nearest point on that line.

CADTutor.zip

Link to comment
Share on other sites

Adjust your dimension style and explode block witn survey plan:

 

(defun c:pdis(/ cCurve cBlock dPt1 dPt2)
 (vl-load-com)
 (if
   (and
     (setq cCurve(entsel "\nSelect curve to measure > "))
     (member(cdr(assoc 0(entget(car cCurve))))
     '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE"))
     ); end and
     (while
       (and
  (setq cBlock(entsel "\nSelect block or Esc to Quit > "))
  (=(cdr(assoc 0(entget(car cBlock)))) "INSERT")
  ); end and
(progn
    (setq dPt1(cdr(assoc 10(entget(car cBlock))))
          dPt2(vlax-curve-getClosestPointTo (car cCurve) dPt1))
    (vl-cmdf "_.dimaligned" (trans dPt1 0 1) (trans dPt2 0 1) pause)
  ); end progn
(princ "\n<!> Empty selection or this isn't block <!> ")
); end while
   (princ "\n<!> Empty selection or this isn't curve (line, polyline, etc.) <!> ")
   ); end if
 (princ)
 ); end of c:pdis

Link to comment
Share on other sites

Hi ASMI,

 

I was looking at this problem and thinking to myself... how the heck would I do that.

 

Then you provide the answer with a nice code.

 

But I was looking at the code and see that you use the function:

 

vlax-curve-getClosestPointTo

 

which seems to be quite a handy function :)

 

But, because I do not know how to use Visual LISP all that well, I didn't know whether you first needed to use:

 

vlax-ename->vla-object

 

first.

 

Why is this? and when do you have to use the above?

Link to comment
Share on other sites

In plain AutoLISP, it takes a good bit more code.

;=======================================================================
;    ClosePT.Lsp                                    Jan 08, 2009
;    Find Thge Closest Point From An INSERT to a PATH - 2D
;================== Start Program ======================================
(princ "\nCopyright (C) 1990-2009, Fabricated Designs, Inc.")
(princ "\nLoading ClosePT v1.0")
(setq cpt_ nil lsp_file "ClosePT")

;++++++++++++ Set Modes & Error ++++++++++++++++++++++++++++++++++
(defun cpt_smd ()
(SetUndo)
(setq olderr *error*
     *error* (lambda (e)
               (while (> (getvar "CMDACTIVE") 0)
                      (command))
               (and (/= e "quit / exit abort")
                    (princ (strcat "\nError: *** " e " *** ")))
               (and (= (logand (getvar "UNDOCTL")  8)
                    (command "_.UNDO" "_END" "_.U"))
               (cpt_rmd))
      cpt_var '(("CMDECHO"   . 0) ("MENUECHO"   . 0)
               ("MENUCTL"   . 0) ("MACROTRACE" . 0)
               ("OSMODE"    . 0) ("SORTENTS"   . 119)
               ("LUPREC"    . 2)
               ("BLIPMODE"  . 0) ("EXPERT"     . 0)
               ("SNAPMODE"  . 1) ("PLINEWID"   . 0)
               ("ORTHOMODE" . 1) ("GRIDMODE"   . 0)
               ("ELEVATION" . 0) ("THICKNESS"  . 0)
               ("COORDS"    . 2) ("UCSICON"    . 1)
               ("HIGHLIGHT" . 1) ("REGENMODE"  . 1)
               ("CECOLOR"   . "BYLAYER")
               ("CELTYPE"   . "BYLAYER")))
(foreach v cpt_var
  (and (getvar (car v))
       (setq cpt_rst (cons (cons (car v) (getvar (car v))) cpt_rst))
       (setvar (car v) (cdr v))))
(princ (strcat (getvar "PLATFORM") " Release " (ver)))
(princ))

;++++++++++++ Return Modes & Error +++++++++++++++++++++++++++++++
(defun cpt_rmd ()
 (setq *error* olderr)
 (foreach v cpt_rst (setvar (car v) (cdr v)))
 (command "_.UNDO" "_END")
 (prin1))

;++++++++++++ Set And Start An Undo Group ++++++++++++++++++++++++
(defun SetUndo ()
(and (zerop (getvar "UNDOCTL"))
     (command "_.UNDO" "_ALL"))
(and (= (logand (getvar "UNDOCTL") 2) 2)
     (command "_.UNDO" "_CONTROL" "_ALL"))
(and (= (logand (getvar "UNDOCTL")  8)
     (command "_.UNDO" "_END"))
(command "_.UNDO" "_GROUP"))

;;;++++++++++ 2D Is Point On ARC ++++++++++++++++++++++++++++++++++++++
;;;ARG -> ARC_Ename  TestPoint  Fuzz
;;;RET -> T nil
(defun is_pt_on_arc (en tp fz / ed ce ra sa ea ta)

  (setq ed (entget en)
        ce (p2d (cdr (assoc 10 ed)))
        ra (cdr (assoc 40 ed))
        sa (cdr (assoc 50 ed))
        ea (cdr (assoc 51 ed))
        ta (angle ce tp)
        tp (p2d tp))
  (and (equal (distance ce tp) ra fz)
       (if (> sa ea)
           (or (>= ta sa)
               (<= ta ea))
           (and (<= ta ea)
                (>= ta sa)))))

;;;++++++++++ 2D Intersections Of Line & Arc ( Circle ) ++++++++++++++++
;;;ARG -> LINE_ename ARC_ename ( CIRCLE or ARC )
;;;RET -> nil or List_Of_Points
;;;ERROR = None

(defun inter_line_arc (l10 l11 arc / a10 rad ip1 ip2)

(setq l10 (p2d l10)
     l11 (p2d l11)
     a10 (p2d (cdr (assoc 10 (entget arc))))
     rad (cdr (assoc 40 (entget arc)))
     ip1 (polar a10 (angle l10 l11) rad)
     ip2 (polar a10 (angle l11 l10) rad))

(cond ((is_pt_on_arc arc ip1 1e-
      ip1)
     ((is_pt_on_arc arc ip2 1e-
      ip2)))


;;;FIND CLOSEST POINT TO LINE FORM GIVEN POINT
;;;ARG -> POINT LINE_ENAME
;;;RET -> POINT
(defun find_near_line (p l / ld l10 l11 tp)

 (setq ld (entget l)
       l10 (p2d (cdr (assoc 10 ld)))
       l11 (p2d (cdr (assoc 11 ld)))
         p (p2d p))

 (cond ((setq tp (inters l10 l11
                         p (polar p (+ (angle l10 l11) (* pi 0.5)) 1))))
       ((if (< (distance p l10)
               (distance p l11))
            (setq tp l10)
            (setq tp l11))))
tp)

;************ Main Program ***************************************
(defun cpt_ (/ olderr cpt_var cpt_rst ss bn bp ls pn pd pf fe fd pc ts
             cp np p2d)
 (cpt_smd)

 (setq p2d (lambda (p) (list (car p) (cadr p))))

 (while (or (not ss)
            (> (sslength ss) 1))
        (princ "\nSelect Block To Test:   ")
        (setq ss (ssget (list (cons 0 "INSERT")
                              (if (getvar "CTAB")
                                  (cons 410 (getvar "CTAB"))
                                  (cons 67 (- 1 (getvar "TILEMODE"))))))))
 (setq bn (ssname ss 0)
       bp (p2d (trans (cdr (assoc 10 (entget bn))) bn 0)))

 (while (or (not ls)
            (> (sslength ls) 1))
        (princ "\nSelect Path To Test:   ")
        (setq ls (ssget (list (cons 0 "LINE,*POLYLINE")
                              (if (getvar "CTAB")
                                  (cons 410 (getvar "CTAB"))
                                  (cons 67 (- 1 (getvar "TILEMODE")))))))
        (and ls
          (setq pn (ssname ls 0)
                pd (entget pn)
                pf (cdr (assoc 70 pd)))
          (= "POLYLINE" (cdr (assoc 0 pd)))
          (> pf 15)
          (princ "\nPOLYLINE MESHES CANNOT BE USED")
          (setq ls nil)))

 (command "_.COPY" pn "" '(0 0 0) '(0 0 0))
 (setq pc (entlast) fe pc)
 (command "_.EXPLODE" pc)

 (setq fe (entnext fe)
       ts (ssadd))

 (while fe
      (ssadd fe ts)
      (setq fd (entget fe))
      (cond ((= "LINE" (cdr (assoc 0 fd)))
             (setq np (find_near_line bp fe)))
            ((= "ARC" (cdr (assoc 0 fd)))
             (setq np (inter_line_arc bp (cdr (assoc 10 fd)) fe))))
      (cond ((not np))
            ((not cp)
             (setq cp np))
            (T
             (setq cp (if (> (distance cp bp)
                             (distance np bp))
                       np cp))))
      (setq fe (entnext fe)))

 (command "_.ERASE" pc ts "")
 (redraw)

 (princ "\nClosest Point in 2D From Block To Path Is ")
 (prin1 cp)

 (cpt_rmd))

;************ Load Program ***************************************
(defun C:ClosePT () (cpt_))
(if cpt_ (princ "\nClosePT Loaded\n"))
(prin1)
;|================== End Program =======================================

AS IS -David

Link to comment
Share on other sites

Blimey David, I see why they introduced VL!...

 

Nice code though - did you already have it, or did you type it just now?... :P

 

 

And ASMI, thanks for the advice - am I safe in the knowledge that every vlax-curve- function I use just needs an ename, (after vl-load-com), and that I don't have to go through the palava of trying to convert it..

Link to comment
Share on other sites

> David Bentel

 

What for this shaman dances with _.EXPLODE, _.UNDO if vlax-curve-GetClosestPointTo and vlax-curve-GetClosestPointToProjection (for 3D) function exists?

 

I respect you as programmer and also respect LISP as language, but a bit do not understand your aversion for ActiveX programing :)

Link to comment
Share on other sites

> David Bentel

 

What for this shaman dances with _.EXPLODE, _.UNDO if vlax-curve-GetClosestPointTo and vlax-curve-GetClosestPointToProjection (for 3D) function exists?

 

I respect you as programmer and also respect LISP as language, but a bit do not understand your aversion for ActiveX programing :)

 

Haha, I try to avoid Active X if possible also.... it scares me :oops:

Link to comment
Share on other sites

ASMI, can you just elaborate on your last post about how I will need to use the LISP routine and what exactly it does, please?

 

The example drawing shown had dim styles and associated paraphernalia from the various scales and incarnations of the survey that were used for official use.

 

Cheers to everyone who contributed to this thread.

Link to comment
Share on other sites

ASMI,

 

I work in Release 12 , 13 and 14 for the most part and they do not have activeX capabilities. I only use Acad 2000 for large rendering projects.

 

I never found anything that 'I can't do without' in the later AutoCCAD releases

 

Lee,

 

I use a boilerplate template for real programs. I had the basic ARC and LINE tests. The main body I wrote on the fly. -David

Link to comment
Share on other sites

Ok, I had a quick go with ASMI's version and it already speeds up the current process. However, it would be a good improvement if I could somehow choose many block, by some kind of selection filter (name, layer would be good) and then have the resulting values listed in a table. If this table could also have another column that would show us something unique about the block, something like its coordinate or a particular attribue, I would be delighted.

Link to comment
Share on other sites

One more issue I have, and it's something I forgot to mention initially, is that the tracks and highways on the drawings, the polylines that represent them, are often 3D; however int this instance, we want to treat them as 2D and ignore Z values as this distorts the true distances.

 

Thanks again.

Link to comment
Share on other sites

This is a starter:

 

will return a list of the Block base point, and distance from line.

 


; pdis by ASMI, (modified by Lee Mac)

(defun c:pdis (/ cCurve cBlock index ent dPt1 dPt2 blkDist blklist)
   (vl-load-com)
   (if
   (and
       (setq cCurve (entsel "\nSelect curve to measure > "))
       (member (cdr (assoc 0 (entget (car cCurve))))
           '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE")
       ) ;_  end member
   ) ; end and
      (progn
          (setq cBlock (ssget '((0 . "INSERT")))
            index  (1- (sslength cBlock))
          ) ;_  end setq
          (while (not (minusp index))
          (setq ent  (entget (ssname cBlock index))
            dPt1 (cdr (assoc 10 ent))
            dPt2 (vlax-curve-getClosestPointTo (car cCurve) dPt1)
            blkDist (distance dPt1 dPt2)
          ) ;_  end setq
          (setq blklist (cons (list dPt1 blkDist) blklist)
            index     (1- index)
          ) ;_  end setq
          ) ; end while
      ) ;_  end progn
      (princ "\n<!> Empty selection or this isn't curve (line, polyline, etc.) <!> ")
   ) ; end if
   (alert (vl-princ-to-string blklist))
   (princ)
) ; end of c:pdis

Link to comment
Share on other sites

Slightly better:

 

(defun c:pdis (/ cCurve cBlock index ent dPt1 dPt2 blkDist blklist)
   (vl-load-com)
   (if
   (and
       (setq cCurve (entsel "\nSelect curve to measure > "))
       (member (cdr (assoc 0 (entget (car cCurve))))
           '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE")
       ) ;_  end member
   ) ; end and
      (progn
          (setq cBlock  (ssget '((0 . "INSERT")))
            index   (1- (sslength cBlock))
            blklist "\n"
          ) ;_  end setq
          (while (not (minusp index))
          (setq ent     (entget (ssname cBlock index))
            dPt1     (cdr (assoc 10 ent))
            dPt2     (vlax-curve-getClosestPointTo (car cCurve) dPt1)
            blkDist (distance dPt1 dPt2)
          ) ;_  end setq
          (setq blklist (strcat "\n"
                    (rtos (car dPt1))
                    ","
                    (rtos (cadr dPt1))
                    " <---> "
                    (rtos blkDist)
                    blklist
                ) ;_  end strcat
            index     (1- index)
          ) ;_  end setq
          ) ; end while
      ) ;_  end progn
      (princ "\n<!> Empty selection or this isn't curve (line, polyline, etc.) <!> ")
   ) ; end if
   (alert blklist)
   (princ)
) ; end of c:pdis

Link to comment
Share on other sites

OK, how about this:

 

(defun c:pdis (/ cCurve cBlock txtpnt index ent dPt1 dPt2 blkDist blklist txt)

   (defun makelay (x)
   (if (not (tblsearch "Layer" x))
       (progn
       (setvar "cmdecho" 0)
       (command "-layer" "m" x "")
       (setvar "cmdecho" 1)
       ) ;_  end progn
       (setvar "CLAYER" x)
   ) ;_  end if
   ) ;_  end defun

   (defun Make_Text (txt_pt txt_val)
   (entmake
       (list '(0 . "TEXT")
         '(8 . "TEXT")
         (cons 10 txt_pt)
         (cons 40 2.5)
         (cons 1 txt_val)
         '(50 . 0.0)
         '(7 . "STANDARD")
         '(71 . 0)
         '(72 . 0)
         '(73 . 0)
       ) ; end list
   ) ; end entmake
   ) ;_  end defun

   (vl-load-com)
   (if
   (and
       (setq cCurve (entsel "\nSelect curve to measure > "))
       (member (cdr (assoc 0 (entget (car cCurve))))
           '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE")
       ) ;_  end member
   ) ; end and
      (progn
          (while
          (and
              (setq cBlock (ssget '((0 . "INSERT"))))
              (setq txtpnt (getpoint "\nSelect Point for Table > "))
          ) ;_  end and
             (makelay "TEXT")
             (setq index   (1- (sslength cBlock))
               blklist "\n"
               txt        1
             ) ;_  end setq
             (while (not (minusp index))
             (setq    ent    (entget (ssname cBlock index))
               dPt1    (cdr (assoc 10 ent))
               dPt2    (vlax-curve-getClosestPointTo (car cCurve) dPt1)
               blkDist    (distance dPt1 dPt2)
             ) ;_  end setq
             (setq    blklist    (strcat    (rtos (car dPt1) 2 1)
                       ","
                       (rtos (cadr dPt1) 2 1)
                       " <---> "
                       (rtos blkDist 2 1)
                   ) ;_  end strcat
             ) ;_  end setq
             (Make_Text (polar txtpnt (* pi 1.5) (* 3.5 txt)) blklist)
             (setq    index (1- index)
               txt   (1+ txt)
             ) ;_  end setq
             ) ; end while
          ) ;_  end while
      ) ;_  end progn
      (princ "\n<!> Empty selection or this isn't curve (line, polyline, etc.) <!> ")
   ) ; end if
   (princ)
) ;_  end defun

Link to comment
Share on other sites

Sorry for all the posts!

 

One more update:

 

(defun c:pdis (/ oldlay cCurve cBlock txtpnt index ent dPt1 dPt2 blkDist blklist txt)

   (defun makelay (x)
   (if (not (tblsearch "Layer" x))
       (progn
       (setvar "cmdecho" 0)
       (command "-layer" "m" x "")
       (setvar "cmdecho" 1)
       ) ;_  end progn
       (setvar "CLAYER" x)
   ) ;_  end if
   ) ;_  end defun

   (defun Make_Text (txt_pt txt_val)
   (entmake
       (list '(0 . "TEXT")
         '(8 . "TEXT")
         (cons 10 txt_pt)
         (cons 40 2.5)
         (cons 1 txt_val)
         '(50 . 0.0)
         '(7 . "STANDARD")
         '(71 . 0)
         '(72 . 0)
         '(73 . 0)
       ) ; end list
   ) ; end entmake
   ) ;_  end defun

   (vl-load-com)
   (setq oldlay (getvar "clayer"))
   (if
   (and
       (setq cCurve (entsel "\nSelect curve to measure > "))
       (member (cdr (assoc 0 (entget (car cCurve))))
           '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE")
       ) ;_  end member
   ) ; end and
      (progn
          (while
          (and
              (setq cBlock (ssget '((0 . "INSERT"))))
              (setq txtpnt (getpoint "\nSelect Point for Table > "))
          ) ;_  end and
             (makelay "TEXT")
             (setq index   (1- (sslength cBlock))
               blklist "\n"
               txt        1
             ) ;_  end setq
             (while (not (minusp index))
             (setq    ent    (entget (ssname cBlock index))
               dPt1    (cdr (assoc 10 ent))
               dPt2    (vlax-curve-getClosestPointTo (car cCurve) dPt1)
               blkDist    (distance dPt1 dPt2)
             ) ;_  end setq
             (setq    blklist    (strcat    (rtos (car dPt1) 2 1)
                       ","
                       (rtos (cadr dPt1) 2 1)
                       "   <--->   "
                       (rtos blkDist 2 1)
                   ) ;_  end strcat
             ) ;_  end setq
             (Make_Text (polar txtpnt (* pi 1.5) (* 3.5 txt)) blklist)
             (setq    index (1- index)
               txt   (1+ txt)
             ) ;_  end setq
             ) ; end while
          ) ;_  end while
      ) ;_  end progn
      (princ "\n<!> Empty selection or this isn't a Curve (line, polyline, etc.) <!> ")
   ) ; end if
   (setvar "clayer" oldlay)
   (princ)
) ;_  end defun

Link to comment
Share on other sites

Opps! How mach new listings. Ok Lee Mac. Coordinates, tables and so on is good training. :)

 

I will look it tomorrow because it is time to sleep.

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...