TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: cadmoogle on November 12, 2008, 11:34:23 PM
-
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
;;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
(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)
)
-
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.
;;==============================================
;; 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))))
-
Daniel,
Very little testing but should get your started.
;; 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)
-
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.
-
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.
-
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
-
Can you upload a sample DWG?
My method may suffer some problems if it has to zoom too far out.
-
I have an update as the ssget will not work unless zoom to proper scale.
This may be a bit slow on 7000 meters. :)
;; 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
-
......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.
-
Yes, very good, I can make use of this.
-
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.
-
Do it all with ActiveX Alan. That way it could run through ObjectDBX. :-D If I had time, I would help, but real work is coming in now, so.....
-
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!!
-
instead of getting drunk on friday night :)
(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)
)
-
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.
-
Thanks for all of the help and input with the codes. :-D
-
Giving this problem some thought, Ideally the Water main would be on a separate layer
and the Lateral to the Water Meter would be on another layer.
You could then select all water mains in one selection set
select all lateral in another selection set
and lastly select all Water meter blocks in a third selection set.
Given that the "Insert Point" of the water meter block is where the block is inserted
at the end of the line, then you could test each lateral to see if one end point matched
any existing water meter insert points. You could also test each lateral end point with
the intersectwith function to see if it attached to a water main.
If both test failed for a given lateral end then a water meter block is added.
There would be a problem with Water Mains if not on a separate layer. This would only
occur if there was a dead end. If the end of run had a lateral attached then no problem.
One way to identify Water Mains is that they would have more than one intersect.