Topic: Find dangles with code

[cadmoogle]

The code below is used to copy blocks to end of a line. Does anyone know how or what the code is to find only the dangle side of a line and not just the end. A dangle is a side of a line that ...dangles, meaning it does not intersect with another line. I'm going to use it for adding meters to my service laterals. If I run it now it will put the block on the end of every line even if it intersects with another line, and I do not need that. I did search around and find a SKI_NODE lisp that would test for dangles, but it does the same as this code, it hits every side of the line. Basically I need it to ignore the line if it intersects/touches or is within 0.5 distance of another line. Any ideas?

 

Thanks in advance,

Daniel

 

 

Code: [Select]


;;Block to end of line command

::Original by Gliderider and modified for blocks by cadmoogle

(defun dxf (code elist)

   (cdr (assoc code elist))

);defun

(defun c:blockend ()

(setq bname (getstring t "\nName of block to copy: "))

(setq lset (ssget '((0 . "line")))   ;filter line in selection set

    setlen (sslength lset)       ;setq number of entties in selection set,

    count  0                          ; setq count(er) to 0

  );setq

  (repeat setLen                             ;repeat setlen times

(setq e1 (ssname lset count)   ;setq ename to be the "0..." entity in selection set lset

         e2 (entget e1)

          p1 (dxf 10 e2)

          p2 (dxf 11 e2)

   );setq

(command "-insert" bname p1 "" ""

                 "-insert" bname p2 "" "")

 (setq count (+ 1 count))                  ; add 1 to Count(er)

  );repeat

 (princ "\nAll blocks have been copied")

 (princ)               

);defun

 

 


 

 

Here is the Ski_node lisp

 

Code: [Select]


(defun c:ski_node (/ ss)

  ;(c:ski_node)

  (if (setq ss (ssget '((0 . "*line") (8 . "*AQ010"))))

    (princ

      (strcat

        "\n"

        (itoa

          (length

            (mapcar

              (function

                (lambda (x)

                  (if (null (ssget "_X" (list '(0 . "POINT,CIRCLE") (cons 10 x))))

                    (entmakex

                      (list

                        '(0 . "CIRCLE")

                        (cons 10 x)

                        '(40 . 0.006)

                      ) ;_  list

                    ) ;_  entmakex

                  ) ;_  if

                ) ;_  lambda

              ) ;_  function

              (apply (function append)

                     (mapcar

                       (function

                         (lambda (x)

                           (list

                             (vlax-curve-getStartPoint x)

                             (vlax-curve-getEndPoint x)

                           ) ;_  list

                         ) ;_  lambda

                       ) ;_  function

                       (vl-remove-if

                         (function listp)

                         (mapcar (function cadr) (ssnamex ss))

                       ) ;_  vl-remove-if

                     ) ;_  mapcar

              ) ;_  apply

            ) ;_  mapcar

          ) ;_  length

        ) ;_  itoa

        " ....errors found"

      ) ;_  strcat

    ) ;_  princ

  ) ;_  if

  (princ)

)



 

[CAB]

You can use something like this to get objects at the end of the line.
pt should be the end point to be tested. If the line is the only object in the ss
then it is a dangler.

Note that this is just a code snippet & you should zoom extents begore using ssget
in this way.

Code: [Select]

;;==============================================
;;  CAB version
            ;; do a ssget crossing the size of the pickbox at the pick point
            (setq SZ (getvar "SCREENSIZE")    ; screen size in pixels
                  VS   (getvar "VIEWSIZE")    ; screen height in drawing units
                  PB   (getvar "pickbox")     ; get current pickbox size
                  SWP  (car SZ)               ; width of screen in pixels
                  SHP  (cadr SZ)              ; height of screen in pixels
                  AR   (/ SWP SHP)            ; aspect ratio width/height
                  WSD  (* VS AR)              ; width of screen dwg units = ratio times height
                  PPDU (/ WSD SWP)            ; pixels per drawing unit
                  BOX (/ (* VS (* 2 PB)) SHP) ; drawing units per pixel
            )
            (setq pt1 (polar pt 0.785 box)
                  pt2 (polar pt 3.93 box))
            (setq ss (ssget "_C" pt1 pt2 (list(sstypes typs))))

[CAB]

Daniel,
Very little testing but should get your started.

Code: [Select]

;;  BlockAddEOL.lsp 
;;  Block Add to End Of Line
;;  CAB 11.13.08  Version 1.1

(defun c:block2end (/ ss s1 bname ent ename lset doc space s e i )
  (vl-load-com)
  ;;  sub to insert the block
  (defun InsertBlock (bn pt ang lay aspace)
      (setq blk (vla-insertblock
  aspace
  (vlax-3d-point pt) ; insert point
  bn ; block name
  1.  ; scale x
  1.
  1.
  ang  ; radians
)
      )
     (vla-put-layer blk lay)
    blk
  )
  ;;; Returns object to active space (ModelSpace or PaperSpace )
  ;;  CAB 05/31/07
  (defun activespace (doc)
    (if (or (= acmodelspace (vla-get-activespace doc))
            (= :vlax-true (vla-get-mspace doc)))
        (vla-get-modelspace doc)
        (vla-get-paperspace doc)
    )
  )

  (defun getss@ (pt typs lay / ss sz vs pb swp ar wsd ppdu box)
    ;;==============================================
    ;;  CAB version
    ;; do a ssget crossing the size of the pickbox at the pick point
    (setq SZ   (getvar "SCREENSIZE") ; screen size in pixels
          VS   (getvar "VIEWSIZE") ; screen height in drawing units
          PB   (getvar "pickbox") ; get current pickbox size
          SWP  (car SZ) ; width of screen in pixels
          SHP  (cadr SZ) ; height of screen in pixels
          AR   (/ SWP SHP) ; aspect ratio width/height
          WSD  (* VS AR) ; width of screen dwg units = ratio times height
          PPDU (/ WSD SWP) ; pixels per drawing unit
          BOX  (/ (* VS (* 2 PB)) SHP) ; drawing units per pixel
    )
    (setq ss (ssget "_C"
                    (polar pt 0.785 box)
                    (polar pt 3.93 box)
                    (list (cons 0 typs) (cons 8 lay))
             )
    )
  )
 
  ;;=============================
  ;;  Start Here
  (setq LineLay "*") ; filter for line layer
  (setq blklay "0")  ; filter for block layer
  (prompt "\nSelect block to use or ENTER key to name block.")
  (if
    (and
      (or
       (and (setq ss (ssget "_+.:E:S" '((0 . "INSERT"))))
            (setq ent (ssname ss 0))
            (setq bname (cdr(assoc 2 (entget ent)))))
       (and (setq bname (getstring t "\nName of block to copy: "))
            (or (tblsearch "Block" bname)
                (prompt (strcat "Cannot find Block " bname ", Ending."))))
      )
      (or (prompt "\nSelect lines to test.")
          (setq lset (ssget (list '(0 . "line")(cons 8 LineLay))))   ;filter line in selection set
      )
    )
      (progn
        (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
              space (activespace doc))
        (vla-EndUndoMark doc)
        (vla-StartUndoMark doc)
        (setq i -1)
        (while (setq ename (ssname lset (setq i (1+ i))))
          (setq elst (entget ename)
                s (cdr(assoc 10 elst))
                e (cdr(assoc 11 elst)))
          (if (= (sslength (setq s1 (getss@ s "LINE" Linelay))) 1)
            (InsertBlock bname s (angle e s) blklay space)
          )
          (if (= (sslength (setq s1 (getss@ e "LINE" Linelay))) 1)
            (InsertBlock bname e (angle s e) blklay space)
          )
        )
        (vla-EndUndoMark doc)
      )
  ) ; endif

 (princ "\nThe blocks have been copied")
 (princ)               
)
(princ)

[cadmoogle]

Cool thank you. Wizman also responed today with some code on cadalyst.com
http://forums.cadalyst.com/showthread.php?t=6052&page=2

I'll test this code out tomorrow. I have tested Wizman's and it works great. Thanks for all of the help guys, this will save me so much time. I was starting to fear the 7,000 meters that needed to be placed on the service laterals.

[CAB]

I see he included LWploylines. The following routine does too.
Note that the block is inserted at the angle of the end of the pline or line.
Also after the "Start Here" there are some layer filters that can be set. Now they are set to any layer.
I also filter out closed polylines.

Old code removed. See new code in another post.

[cadmoogle]

Thanks again CAB.

I tested the code this morning and it appeared to only copy the block once for both lines and polylines. It did rotate the block which was helpful.

Daniel

[CAB]

Can you upload a sample DWG?

My method may suffer some problems if it has to zoom too far out.

[CAB]

I have an update as the ssget will not work unless zoom to proper scale.
This may be a bit slow on 7000 meters.

Code: [Select]

;;  BlockAddEOL.lsp 
;;  Block Add to End Of Line
;;  CAB 11.14.08  Version 1.3

(defun c:block2end (/ ss s1 bname ent ename lset acad doc space s e i bb bcnt)
  (vl-load-com)
  ;;  sub to insert the block
  (defun InsertBlock (bn pt ang lay aspace)
      (setq blk (vla-insertblock
  aspace
  (vlax-3d-point pt) ; insert point
  bn ; block name
  1.  ; scale x
  1.
  1.
  ang  ; radians
)
      )
     (vla-put-layer blk lay)
    blk
  )
  ;;; Returns object to active space (ModelSpace or PaperSpace )
  ;;  CAB 05/31/07
  (defun activespace (doc)
    (if (or (= acmodelspace (vla-get-activespace doc))
            (= :vlax-true (vla-get-mspace doc)))
        (vla-get-modelspace doc)
        (vla-get-paperspace doc)
    )
  )

  (defun getss@ (pt typs lay / ss sz vs pb swp ar wsd ppdu box)
    ;;==============================================
    ;;  CAB version
    ;; do a ssget crossing the size of the pickbox at the pick point
    (setq SZ   (getvar "SCREENSIZE") ; screen size in pixels
          VS   (getvar "VIEWSIZE") ; screen height in drawing units
          PB   (getvar "pickbox") ; get current pickbox size
          SWP  (car SZ) ; width of screen in pixels
          SHP  (cadr SZ) ; height of screen in pixels
          AR   (/ SWP SHP) ; aspect ratio width/height
          WSD  (* VS AR) ; width of screen dwg units = ratio times height
          PPDU (/ WSD SWP) ; pixels per drawing unit
          BOX  (/ (* VS (* 2 PB)) SHP) ; drawing units per pixel
    )
    (setq ss (ssget "_C"
                    (polar pt 0.785 box)
                    (polar pt 3.93 box)
                    (list (cons 0 typs) (cons 8 lay))
             )
    )
  )

  ;;  CAB 10/17/2006
  ;;  Get bounding box of selection set
  ;;  returns a point list in WCS coordinates ((lower left)(upper right))
  (defun ssboundingbox (ss / i ent lst ptlst mnpt mxpt)
    (setq i -1)
    (while (setq ent (ssname ss (setq i (1+ i))))
      (setq lst (cons (vlax-ename->vla-object ent) lst))
    )
    (mapcar '(lambda (x)
               (vla-getboundingbox x 'mnpt 'mxpt)
               (setq ptlst (cons (vlax-safearray->list mnpt) ptlst))
               (setq ptlst (cons (vlax-safearray->list mxpt) ptlst))
             )
            lst
    )
    (list  ;  following by Tony Tanzillo, mod by CAB
      (vlax-3d-point (apply 'mapcar (cons 'min ptlst)))
      (vlax-3d-point (apply 'mapcar (cons 'max ptlst)))
    )
  )


 
  ;;=============================
  ;;  Start Here
  (setq LineLay "*") ; filter for line layer
  (setq blklay "0")  ; filter for block layer
  (prompt "\nSelect block to use or ENTER key to name block.")
  (if
    (and
      (or
       (and (setq ss (ssget "_+.:E:S" '((0 . "INSERT"))))
            (setq ent (ssname ss 0))
            (setq bname (cdr(assoc 2 (entget ent)))))
       (and (setq bname (getstring t "\nName of block to copy: "))
            (or (tblsearch "Block" bname)
                (prompt (strcat "Cannot find Block " bname ", Ending."))))
      )
      (or (prompt "\nSelect lines to test.")
          (setq lset (ssget (list (cons 8 LineLay)
                                  '(-4 . "<OR")
                                   '(0 . "LINE")
                                   '(-4 . "<AND")
                                     '(0 . "LWPOLYLINE")
                                     '(-4 . "<not")
                                     '(-4 . "&")
                                     '(70 . 1)
                                     '(-4 . "NOT>")
                                   '(-4 . "AND>")
                                  '(-4 . "OR>")
                                  )))   ;filter line in selection set
      )
    )
      (progn
        (setq acad (vlax-get-acad-object)
              doc   (vla-get-ActiveDocument acad)
              space (activespace doc)
              bcnt  0)
        (vla-EndUndoMark doc)
        (vla-StartUndoMark doc)
        (setq i -1)
        (while (setq ename (ssname lset (setq i (1+ i))))
          (setq s (vlax-curve-getStartPoint  ename)
                e (vlax-curve-getEndPoint  ename))
              (vla-zoomwindow acad (vlax-3d-point (MapCar '- s '(50 50)))
                              (vlax-3d-point (MapCar '+ s '(50 50))))
          (if (= (sslength (setq s1 (getss@ s "LINE,LWPOLYLINE,INSERT" Linelay))) 1)
         
            (progn
              (InsertBlock bname s (angle (vlax-curve-getFirstDeriv ename 0.05) '(0 0)) blklay space)
              (setq bcnt (1+ bcnt)))
          )
              (vla-zoomwindow acad (vlax-3d-point (MapCar '- e '(50 50)))
                              (vlax-3d-point (MapCar '+ e '(50 50))))
          (if (= (sslength (setq s1 (getss@ e "LINE,LWPOLYLINE,INSERT" Linelay))) 1)
            (progn
              (InsertBlock bname e (angle '(0 0) (vlax-curve-getFirstDeriv ename
                                                 (- (vlax-curve-getendparam ename) 0.05))) blklay space)
                 (setq bcnt (1+ bcnt)))
          )
        )
        (vla-EndUndoMark doc)
      )
  ) ; endif

 (princ (strcat "\n" (itoa bcnt) " blocks have been added to the DWG."))
 (princ)               
)
(princ)
PS this routine will not add a second block if one is already there

[wizman]

......PS this routine will not add a second block if one is already there

very good programming skills allan, im always learning from your works, good problem as well.

[GDF]

Yes, very good, I can make use of this.

[CAB]

Thanks all...

I'm still trying to think of a better solution.
The ssget works well but the restrictions requiring zooming make it slow for some 7000 blocks. > 4 min. on my machine.

[T.Willey]

Do it all with ActiveX Alan.  That way it could run through ObjectDBX.    If I had time, I would help, but real work is coming in now, so.....

[Matt__W]

Every time I see this thread I think of....


"The angle of the dangle is inversely proportional to the heat of the beat." - Beavis

*sigh*  Feels good to have gotten that out of my system.  Carry on!!

[VovKa]

instead of getting drunk on friday night

Code: [Select]

(defun FindSliver (EntsList Fuzz / CoordsList P)
  (foreach EntName EntsList
    (foreach P (list (vlax-curve-getStartPoint EntName)
     (vlax-curve-getEndPoint EntName)
       )
      (if
(not
  (vl-some
    (function
      (lambda (e)
(and (<= (distance (vlax-curve-getClosestPointTo e P) P)
Fuzz
     )
     (not (equal EntName e))
)
      )
    )
    EntsList
  )
)
(setq CoordsList
(cons (cons P
    (vlax-curve-getFirstDeriv
      EntName
      (vlax-curve-getParamAtPoint EntName P)
    )
      )
      CoordsList
)
)
      )
    )
  )
  CoordsList
)
(defun C:MarkSliver (/ SS BlockName Fuzz)
  (if (and (setq SS (ssget (list (cons 0 "LINE,LWPOLYLINE"))))
   (setq BlockName (getstring "\nEnter block name: " t))
   (tblsearch "BLOCK" BlockName)
   (setq Fuzz (getdist "\nEnter fuzz distance: "))
      )
    (foreach P (FindSliver
(vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
Fuzz
       )
      (entmake (list (cons 0 "INSERT")
     (cons 2 BlockName)
     (cons 10 (car p))
     (cons 41 1)
     (cons 42 1)
     (cons 43 1)
     (cons 50 (angle '(0 0) (cdr p)))
       )
      )
    )
  )
  (princ)
)


[wizman]

instead of getting drunk on friday night

its worth it sir, you've produced a good code also.

...just tried it, very fast also, thanks for sharing.