- Home
- /
- Architecture, Engineering & Construction
- /
- AutoCAD Forums
- /
- Visual LISP, AutoLISP and General Customization Forum
- /
- flatten command moves diagram a little
flatten command moves diagram a little
Options
- Subscribe to RSS Feed
- Mark Topic as New
- Mark Topic as Read
- Float this Topic for Current User
- Bookmark
- Subscribe
- Mute
- Printer Friendly Page
flatten command moves diagram a little
Advocate
285 Views
3 Replies
286 Views
3 Replies
Replies (3)
Message 2 of 4
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
There's a warning on using Express Tools Flatten Hide option as stated under "Note" here:
Message 3 of 4
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
So i have the code below and without flatten it is not working 100% correctly please view dwg and pic for what i mean. The line highlighted is suppose to be broken up into several pieces and any duplicate lines should be removed.
(acet-autoload2 '("FLATTENSUP.LSP" (acet-flatn ss hide)))
(defun ZZZ ()
(prompt "Zoom to LIMMIN / LIMMAX. ")
(setvar "CMDECHO" 0)
(vl-cmdf ".UCS" "World")
(vl-cmdf ".ZOOM" (getvar "LIMMIN") (getvar "LIMMAX"))
(vl-cmdf ".UCS" "Previous")
(setvar "CMDECHO" 1)
(princ)
);end ZZZ
(defun c:CleanUp2 (/ GetLines GetText GetArrows)
(ZZZ)
(setq GetLines (ssget "_A" '((0 . "LINE"))))
(vl-cmdf "._erase" GetLines "")
(setq GetText (ssget "_A" '((0 . "TEXT"))))
(vl-cmdf "._erase" GetText "")
(setq GetArrows (ssget "x" (list (cons 0 "lwpolyline") (cons 70 0))))
(vl-cmdf "._erase" GetArrows "")
(princ)
(ocz)
)
(defun ocz (/ xAxis1 xAxis2 xAxis3 xAxis4 yAxis1 yAxis2 yAxis3 yAxis4)
(setq sset (ssget "x" (list (cons 0 "lwpolyline") (cons 70 1))))
(if sset
(progn
(setq itm 0
num (sslength sset)
)
; (if (itm /= 1)
(while (< itm num)
(setq hnd (ssname sset itm))
(setq ent (entget hnd))
(setq obj (cdr (assoc 0 ent)))
(cond
((= obj "LWPOLYLINE")
(if (= (cdr (assoc 38 ent)) nil)
(setq elv 0.0)
(setq elv (cdr (assoc 38 ent)))
)
(foreach rec ent
(if (= (car rec) 10)
(progn
(setq pnt (cdr rec))
(setq pnt (trans pnt 0 1))
;;**CAB
(cond ((null xAxis1)
(setq xAxis1 (strcat (rtos (car pnt) 2 3)))
(setq yAxis1 (strcat (rtos (cadr pnt) 2 3)))
)
((null xAxis2)
(setq xAxis2 (strcat (rtos (car pnt) 2 3)))
(setq yAxis2 (strcat (rtos (cadr pnt) 2 3)))
)
((null xAxis3)
(setq xAxis3 (strcat (rtos (car pnt) 2 3)))
(setq yAxis3 (strcat (rtos (cadr pnt) 2 3)))
)
((null xAxis4)
(setq xAxis4 (strcat (rtos (car pnt) 2 3)))
(setq yAxis4 (strcat (rtos (cadr pnt) 2 3)))
(if (= xAxis1 xAxis2)
(progn
(setq p1 (strcat xAxis1 "," yAxis1))
(setq p2 (strcat xAxis2 "," yAxis2))
(command "line" p1 p2 "")
)
)
(if (= xAxis1 xAxis3)
(progn
(setq p3 (strcat xAxis1 "," yAxis1))
(setq p4 (strcat xAxis3 "," yAxis3))
(command "line" p3 p4 "")
)
)
(if (= xAxis1 xAxis4)
(progn
(setq p5 (strcat xAxis1 "," yAxis1))
(setq p6 (strcat xAxis4 "," yAxis4))
(command "line" p5 p6 "")
)
)
(if (= xAxis3 xAxis2)
(progn
(setq p7 (strcat xAxis3 "," yAxis3))
(setq p8 (strcat xAxis2 "," yAxis2))
(command "line" p7 p8 "")
)
)
(if (= xAxis4 xAxis2)
(progn
(setq p9 (strcat xAxis4 "," yAxis4))
(setq p10 (strcat xAxis2 "," yAxis2))
(command "line" p9 p10 "")
)
)
(if (= xAxis3 xAxis4)
(progn
(setq p11 (strcat xAxis3 "," yAxis3))
(setq p12 (strcat xAxis4 "," yAxis4))
(command "line" p11 p12 "")
)
)
(if (= yAxis1 yAxis2)
(progn
(setq p1 (strcat xAxis1 "," yAxis1))
(setq p2 (strcat xAxis2 "," yAxis2))
(command "line" p1 p2 "")
)
)
(if (= yAxis1 yAxis3)
(progn
(setq p3 (strcat xAxis1 "," yAxis1))
(setq p4 (strcat xAxis3 "," yAxis3))
(command "line" p3 p4 "")
)
)
(if (= yAxis1 yAxis4)
(progn
(setq p5 (strcat xAxis1 "," yAxis1))
(setq p6 (strcat xAxis4 "," yAxis4))
(command "line" p5 p6 "")
)
)
(if (= yAxis3 yAxis2)
(progn
(setq p7 (strcat xAxis3 "," yAxis3))
(setq p8 (strcat xAxis2 "," yAxis2))
(command "line" p7 p8 "")
)
)
(if (= yAxis4 yAxis2)
(progn
(setq p9 (strcat xAxis4 "," yAxis4))
(setq p10 (strcat xAxis2 "," yAxis2))
(command "line" p9 p10 "")
)
)
(if (= yAxis3 yAxis4)
(progn
(setq p11 (strcat xAxis3 "," yAxis3))
(setq p12 (strcat xAxis4 "," yAxis4))
(command "line" p11 p12 "")
)
)
(setq xAxis1 nil)
(setq xAxis2 nil)
(setq xAxis3 nil)
(setq xAxis4 nil)
)
)
)
)
)
)
(t nil)
)
(setq itm (1+ itm))
)
)
)
(vl-cmdf "._erase" sset "")
(princ)
(FLATTEN)
)
(defun Flatten (/ ss ans)
(acet-error-init (list nil 1))
(if (not acet:flatn-hide)
(setq acet:flatn-hide "No")
) ;if
(if (and (setq ss (ssget "_A" '((0 . "LINE")))) ;setq
(setq ss (car (acet-ss-filter (list ss nil T))))
) ;and
(progn
(setq ans "yes"
) ;setq
(out if (not ans)
(setq ans acet:flatn-hide)
(setq acet:flatn-hide ans)
) ;if
(if (equal ans "No")
(acet-flatn ss nil)
(acet-flatn ss T)
) ;if
) ;progn then
) ;if
(acet-error-restore)
(princ)
(command "_.-OVERKILL" "_all" "" "Done")
(princ)
(BreakAll)
(if (zerop (getvar "PEDITACCEPT"))
(command "._PEDIT" "_M" (ssget "_A" '((0 . "*POLYLINE,LINE"))) "" "_Y" "")
(command "._PEDIT" "_M" (ssget "_A" '((0 . "*POLYLINE,LINE"))) "" "")
)
;(CreatePath2)
) ;defun c:flatten
(defun CreatePath2 (/ xAxis1
xAxis2 yAxis1 yAxis2 xAxis3
xAxis3 xAxis4 yAxis4 CurrentX
CurrentY PossibleLines MainLine AllLines DidLines CurrentEnt pt ss in sn cl ls sn HasRight HasLeft Leftx Lefty Rightx Righty
)
(setq *des* (open (strcat "C:\\Users\\RPajo\\OneDrive\\Desktop\\Customs\\ISO\\" (getvar "dwgname") ".ISO") "w"))
;(setq *des* (open (strcat "C:\\Users\\RPajo\\OneDrive\\Desktop\\Customs\\ISO\\Test.ISO") "w"))
(setq CurrentX "0")
(setq CurrentY "0")
(setq First 1)
(write-line (strcat "G90 G92 X" CurrentX " Y" CurrentY) *des*)
(setq sset (ssget "_A" '((0 . "*POLYLINE,LINE"))))
(setq PossibleLines (ssadd))
(setq AllLines (ssadd))
(setq DidLines 0)
(if sset
(progn
(setq itm3 0
num3 (sslength sset))
(while (< itm3 num3)
(setq hnd3 (ssname sset itm3))
(ssadd hnd3 AllLines)
(setq itm3 (1+ itm3))
)
)
)
( while (and (/= (sslength AllLines) 0) (/= DidLines 99))
(if sset
(progn
(if (and (/= DidLines 0) (= (rem DidLines 4) 0))
(progn
(write-line "M00" *des*)
(write-line (strcat "G00 X" CurrentX " Y" CurrentY) *des*)
(write-line "M00" *des*)
)
)
(setq itm 0
num (sslength sset))
(while (< itm num)
(setq hnd (ssname sset itm))
(setq ent (entget hnd))
(setq obj (cdr (assoc 0 ent)))
(setq Allowed (IsInList hnd AllLines))
(foreach rec ent
(if (= (car rec) 10)
(progn
(setq pnt (cdr rec))
(setq pnt (trans pnt 0 1))
(cond ((null xAxis1)
(setq xAxis1 (strcat (rtos (car pnt) 2 3)))
(setq yAxis1 (strcat (rtos (cadr pnt) 2 3)))
)
((null xAxis2)
(setq xAxis2 (strcat (rtos (car pnt) 2 3)))
(setq yAxis2 (strcat (rtos (cadr pnt) 2 3)))
(cond
((and (= CurrentX xAxis1) (= CurrentY yAxis1) (= Allowed 1))
(ssadd hnd PossibleLines)
)
((and (= CurrentX xAxis2) (= CurrentY yAxis2) (= Allowed 1))
(ssadd hnd PossibleLines)
)
)
(setq xAxis1 nil)
(setq xAxis2 nil)
)
)
)
)
)
(setq itm (1+ itm))
)
)
)
(if (and (= First 1) (= (sslength PossibleLines) 0))
(progn
(setq First 0)
(setq pnt (list (read Currentx) (read CurrentY) 0.0))
(sssetfirst nil nil)
(setq distanceFromPoint nil)
(setq nearestPointTo nil)
(setq ent nil)
(repeat (setq i (sslength AllLines))
(setq ent (ssname AllLines (setq i (1- i))))
(setq distanceFromPoint
(cons (list (distance pnt
(setq nearestPointTo (vlax-curve-getClosestPointTo ent pnt)))
ent nearestPointTo) distanceFromPoint ))
)
(setq theNearest (Car (vl-sort distanceFromPoint '(lambda (a b)(< (Car a)(car b))))))
(setq EntName (cadr theNearest))
(sssetfirst nil (ssadd EntName))
(setq ent2 (entget EntName))
(foreach rec2 ent2
(if (= (car rec2) 10)
(progn
(setq pnt2 (cdr rec2))
(setq pnt2 (trans pnt2 0 1))
(cond ((null xAxis3)
(setq xAxis3 (strcat (rtos (car pnt2) 2 3)))
(setq yAxis3 (strcat (rtos (cadr pnt2) 2 3)))
)
((null xAxis4)
(setq xAxis4 (strcat (rtos (car pnt2) 2 3)))
(setq yAxis4 (strcat (rtos (cadr pnt2) 2 3)))
(setq pnt3 (list (read xAxis3) (read yAxis3) 0.0))
(if (> (distance pnt2 pnt ) (distance pnt3 pnt))
(progn
(setq CurrentX xAxis3)
(setq CurrentY yAxis3)
(write-line (strcat "G01 X" xAxis3 " Y" yAxis3) *des*)
)
(progn
(setq CurrentX xAxis4)
(setq CurrentY yAxis4)
(write-line (strcat "G01 X" xAxis4 " Y" yAxis4) *des*)
)
)
(setq xAxis3 nil)
(setq xAxis4 nil)
)
)
)
)
)
)
(progn
(setq First 0)
(setq MainLine "Not Found")
(setq DidSomething 0)
(setq HasRight 0)
(setq HasLeft 0)
(if (/= (sslength PossibleLines) 0)
(progn
(setq itm2 0
num2 (sslength PossibleLines)
)
(while (and (< itm2 num2) (/= MainLine "Found"))
(setq hnd2 (ssname PossibleLines itm2))
(setq ent2 (entget hnd2))
(setq obj2 (cdr (assoc 0 ent2)))
(foreach rec2 ent2
(if (= (car rec2) 10)
(progn
(setq pnt2 (cdr rec2))
(setq pnt2 (trans pnt2 0 1))
(cond ((null xAxis3)
(setq xAxis3 (strcat (rtos (car pnt2) 2 3)))
(setq yAxis3 (strcat (rtos (cadr pnt2) 2 3)))
)
((null xAxis4)
(setq xAxis4 (strcat (rtos (car pnt2) 2 3)))
(setq yAxis4 (strcat (rtos (cadr pnt2) 2 3)))
(setq pnt3 (list (read xAxis3) (read yAxis3) 0.0))
(setq pnt (list (read CurrentX) (read CurrentY) 0.0))
(if (and (= CurrentX xAxis3) (= CurrentX xAxis4) (= DidSomething 0))
(progn
(if (and (< (atoi yAxis3) (atoi CurrentY)) (/= yAxis3 CurrentY) (/= pnt pnt3))
(progn
(ssdel hnd2 AllLines)
(print (strcat "Going From (" Currentx ", " Currenty ") to (" xAxis3 ", " yAxis3 ")"))
(write-line (strcat "G01 X" xAxis3 " Y" yAxis3) *des*)
(command "chprop" hnd2 "" "C" 3 "")
(setq CurrentX xAxis3)
(setq CurrentY yAxis3)
(setq DidSomething 1)
(setq MainLine "Found")
)
)
(if (and (< (atoi yAxis4) (atoi CurrentY)) (/= yAxis4 CurrentY) (/= pnt pnt2))
(progn
(ssdel hnd2 AllLines)
(print (strcat "Going From (" Currentx ", " Currenty ") to (" xAxis4 ", " yAxis4 ")"))
(write-line (strcat "G01 X" xAxis4 " Y" yAxis4) *des*)
(command "chprop" hnd2 "" "C" 3 "")
(setq CurrentX xAxis4)
(setq CurrentY yAxis4)
(setq DidSomething 1)
(setq MainLine "Found")
)
)
)
)
(if (and (= Currenty yAxis3) (= Currenty yAxis4) (= DidSomething 0))
(progn
(if (/= Currentx xAxis3 )
(progn
(if (> Currentx xAxis3)
(progn
(setq HasLeft hnd2)
(setq Leftx xAxis3)
(setq Lefty yAxis3)
)
(progn
(setq HasRight hnd2)
(setq Rightx xAxis3)
(setq Righty yAxis3)
)
)
)
)
(if (/= Currentx xAxis4 )
(progn
(if (> Currentx xAxis4)
(progn
(setq HasLeft hnd2)
(setq Leftx xAxis4)
(setq Lefty yAxis4)
)
(progn
(setq HasRight hnd2)
(setq Rightx xAxis4)
(setq Righty yAxis4)
)
)
)
)
)
)
(if (and (= num2 1) (= DidSomething 0))
(progn
(if (or (/= Currentx xAxis3 ) (/= Currenty yAxis3))
(progn
(ssdel hnd2 AllLines)
(print (strcat "Going From (" Currentx ", " Currenty ") to (" xAxis3 ", " yAxis3 ")"))
(write-line (strcat "G01 X" xAxis3 " Y" yAxis3) *des*)
(command "chprop" hnd2 "" "C" 3 "")
(setq CurrentX xAxis3)
(setq CurrentY yAxis3)
(setq DidSomething 1)
)
)
(if (or (and (/= Currentx xAxis4 ) (= DidSomething 0)) (and (/= Currenty yAxis4) (= DidSomething 0)))
(progn
(ssdel hnd2 AllLines)
(print (strcat "Going From (" Currentx ", " Currenty ") to (" xAxis4 ", " yAxis4 ")"))
(write-line (strcat "G01 X" xAxis4 " Y" yAxis4) *des*)
(command "chprop" hnd2 "" "C" 3 "")
(setq CurrentX xAxis4)
(setq CurrentY yAxis4)
(setq DidSomething 1)
)
)
)
)
(if (and (= (1- num2) itm2) (= DidSomething 0))
(progn
(if (/= HasRight 0)
(progn
(ssdel HasRight AllLines)
(print (strcat "Going From (" Currentx ", " Currenty ") to (" Rightx ", " Righty ")"))
(write-line (strcat "G01 X" Rightx " Y" Righty) *des*)
(command "chprop" HasRight "" "C" 3 "")
(setq CurrentX Rightx)
(setq CurrentY Righty)
(setq DidSomething 1)
)
(progn
(if (/= HasLeft 0)
(progn
(ssdel HasLeft AllLines)
(print (strcat "Going From (" Currentx ", " Currenty ") to (" Leftx ", " Lefty ")"))
(write-line (strcat "G01 X" Leftx " Y" Lefty) *des*)
(command "chprop" HasLeft "" "C" 3 "")
(setq CurrentX Leftx)
(setq CurrentY Lefty)
(setq DidSomething 1)
)
(progn
(if (or (/= Currentx xAxis3 ) (/= Currenty yAxis3))
(progn
(ssdel hnd2 AllLines)
(princ (strcat "Going From (" Currentx ", " Currenty ") to (" xAxis3 ", " yAxis3 ")"))
(write-line (strcat "G01 X" xAxis3 " Y" yAxis3) *des*)
(command "chprop" hnd2 "" "C" 3 "")
(setq CurrentX xAxis3)
(setq CurrentY yAxis3)
(setq DidSomething 1)
)
)
(if (or (and (/= Currentx xAxis4 ) (= DidSomething 0)) (and (/= Currenty yAxis4) (= DidSomething 0)))
(progn
(ssdel hnd2 AllLines)
(princ (strcat "Going From (" Currentx ", " Currenty ") to (" xAxis4 ", " yAxis4 ")"))
(write-line (strcat "G01 X" xAxis4 " Y" yAxis4) *des*)
(command "chprop" hnd2 "" "C" 3 "")
(setq CurrentX xAxis4)
(setq CurrentY yAxis4)
)
)
)
)
)
)
)
)
(setq xAxis3 nil)
(setq xAxis4 nil)
)
)
)
)
)
(setq itm2 (1+ itm2))
)
(setq PossibleLines (ssadd))
)
( progn
(setq pnt (list (read Currentx) (read CurrentY) 0.0))
(sssetfirst nil nil)
(setq distanceFromPoint nil)
(setq nearestPointTo nil)
(setq ent nil)
(repeat (setq i (sslength AllLines))
(setq ent (ssname AllLines (setq i (1- i))))
(setq distanceFromPoint
(cons (list (distance pnt
(setq nearestPointTo (vlax-curve-getClosestPointTo ent pnt)))
ent nearestPointTo) distanceFromPoint ))
)
(setq theNearest (Car (vl-sort distanceFromPoint '(lambda (a b)(< (Car a)(car b))))))
(setq EntName (cadr theNearest))
(sssetfirst nil (ssadd EntName))
(setq ent2 (entget EntName))
(foreach rec2 ent2
(if (= (car rec2) 10)
(progn
(setq pnt2 (cdr rec2))
(setq pnt2 (trans pnt2 0 1))
(cond ((null xAxis3)
(setq xAxis3 (strcat (rtos (car pnt2) 2 3)))
(setq yAxis3 (strcat (rtos (cadr pnt2) 2 3)))
)
((null xAxis4)
(setq xAxis4 (strcat (rtos (car pnt2) 2 3)))
(setq yAxis4 (strcat (rtos (cadr pnt2) 2 3)))
(setq pnt3 (list (read xAxis3) (read yAxis3) 0.0))
(if (> (distance pnt2 pnt ) (distance pnt3 pnt))
(progn
;(ssdel EntName AllLines)
;(print (strcat "Going From9 (" Currentx ", " Currenty ") to (" xAxis3 ", " yAxis3 ")"))
;(command "chprop" EntName "" "C" 3 "")
(setq CurrentX xAxis3)
(setq CurrentY yAxis3)
;(setq DidSomething 1)
(shortlinespath pnt pnt3)
)
(progn
;(ssdel EntName AllLines)
;(print (strcat "Going From10 (" Currentx ", " Currenty ") to (" xAxis4 ", " yAxis4 ")"))
;(command "chprop" EntName "" "C" 3 "")
(setq CurrentX xAxis4)
(setq CurrentY yAxis4)
;(setq DidSomething 1)
(shortlinespath pnt pnt2)
)
)
(setq xAxis3 nil)
(setq xAxis4 nil)
)
)
)
)
)
(setq PossibleLines (ssadd))
)
)
(setq DidLines (1+ DidLines))
)
)
)
(write-line "M30" *des*)
(close *des*)
(princ "Done")
)
(defun IsInList( Enitity ListToCheck)
(setq DidFind 0)
(if ListToCheck
(progn
(setq itm4 0
num4 (sslength ListToCheck))
(while (< itm4 num4)
(setq hnd4 (ssname ListToCheck itm4))
(if (equal Enitity hnd4)
(progn
(print)
(setq DidFind 1)
)
)
(setq itm4 (1+ itm4))
)
)
)
(eval DidFind)
)
; Find the path of minimum total length between two given nodes g and f. ;
; Using Dijkstra Algorithm ;
; ;
; See http://tech-algorithm.com/articles/dijkstra-algorithm/ ;
; ;
; Written by ymg August 2013 ;
(defun minpath ( g f nodes edges / brname clnodes closedl dst1 dst2 m minpath minpathn mp new nodname old oldpos openl totdist )
(setq nodes (vl-remove g nodes)
openl (list (list g 0 nil))
closedl nil
)
(foreach n nodes
(setq nodes (subst (list n 0 nil) n nodes))
)
(while (not (equal (caar closedl) f 1))
(setq nodname (caar openl)
totdist (cadar openl)
closedl (cons (car openl) closedl)
openl (cdr openl)
clnodes (mapcar 'car closedl)
)
(foreach e edges
(setq brname nil)
(if (equal (car e) nodname 1)
(setq brname (cadr e))
)
(if (equal (cadr e) nodname 1)
(setq brname (car e))
)
(if brname
(progn
(setq new (list brname (+ (caddr e) totdist) nodname))
(cond
((member brname clnodes))
((setq oldpos (vl-position brname (mapcar 'car openl)))
(setq old (nth oldpos openl))
(if (< (cadr new) (cadr old))
(setq openl (subst new old openl))
)
)
(t (setq openl (cons new openl)))
)
(setq edges (vl-remove e edges))
)
)
)
(setq
openl (vl-sort openl
(function (lambda (a b) (< (cadr a) (cadr b))))
)
)
)
(setq minpath (list (list (car closedl))))
(setq dst1 (cadr (car closedl)))
(setq m 1)
(foreach k closedl
(setq dst2 (cadr k))
(if (not (equal dst1 dst2 1)) (setq m (1+ m) dst1 dst2))
)
(repeat m
(foreach n closedl
(if (= (length minpath) 1)
(if (equal (car n) (caddr (caar minpath)) 1) (setq mp (cons n mp)))
(mapcar '(lambda (x) (if (equal (car n) (caddr (car x)) 1) (setq mp (cons n mp)))) minpath)
)
)
(setq mp (vl-sort mp '(lambda (a b) (not (equal (car b) (car a) 1)))))
(if (= (length minpath) 1)
(setq minpath (mapcar '(lambda (x) (cons x (car minpath))) mp))
(setq minpath (mapcar '(lambda (x) (mapcar '(lambda (y) (if (equal (car x) (caddr (car y)) 1) (cons x y))) minpath)) mp))
)
(setq minpath (mapcar '(lambda (x) (vl-remove nil x)) minpath))
(if (listp (caaaar minpath)) (setq minpath (apply 'append minpath)))
(mapcar '(lambda (x) (if (eq (caddr (car x)) nil) (setq minpathn (cons x minpathn)))) minpath)
(setq mp nil)
)
(setq minpathn (acet-list-remove-duplicates minpathn nil))
(setq minpathn (vl-remove nil minpathn))
)
(defun make3dpl ( ptlst )
(setq i 0)
(foreach pt ptlst
(if (/= i 0 )
(progn
(Print (strcat "going from (" (rtos (car pt) 2 3) ", " (rtos (cadr pt) 2 3) ", 0.0) ->" ))
(write-line (strcat "G01 X" (rtos (car pt) 2 3) " Y" (rtos (cadr pt) 2 3)) *des*)
)
)
(setq i (1+ i))
)
)
(defun shortlinespath ( g f / osm ss i lin p1 p2 linlst ptlst dijkstra ptlstpths pl )
(vl-load-com)
(setq osm (getvar 'osmode))
(setq ss (ssget "_A" '((0 . "*POLYLINE,LINE,CIRCLE"))))
(setq i -1)
(while (setq lin (ssname ss (setq i (1+ i))))
(setq p1 (vlax-curve-getStartPoint lin)
p2 (vlax-curve-getEndPoint lin)
)
(setq linlst (cons (list p1 p2 (distance p1 p2)) linlst))
(setq ptlst (cons p1 ptlst) ptlst (cons p2 ptlst))
)
(setq ptlst (acet-list-remove-duplicates ptlst 1))
(setvar 'osmode 1)
(setq dijkstra (minpath g f ptlst linlst))
(setq ptlstpths (mapcar '(lambda (x) (mapcar 'car x)) dijkstra))
(mapcar '(lambda (x) (make3dpl x)) ptlstpths)
(prompt "\nShortest path length is : ") (princ (rtos (setq len (cadr (last (car dijkstra)))))) (prompt " - you should check length to match data")
(setvar 'osmode osm)
(princ)
)
(defun BreakAll (/ cmd ss NewEnts AllEnts tmp)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(initget 4) ; no negative numbers
(setq Bgap 0)
;; get objects to break
(if (setq ss (ssget "_A" '((0 . "*POLYLINE,LINE,CIRCLE"))))
(setq NewEnts (Break_with ss ss nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(setvar "CMDECHO" cmd)
(princ)
)
(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs
onlockedlayer ssget->vla-list list->3pair GetNewEntities oc
get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList
)
;; ss2brk selection set to break
;; ss2brkwith selection set to use as break points
;; self when true will allow an object to break itself
;; note that plined will break at each vertex
;;
;; return list of enames of new objects
(vl-load-com)
(princ "\nCalculating Break Points, Please Wait.\n")
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; return T if entity is on a locked layer
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
;; return a list of objects from a selection set
;| (defun ssget->vla-list (ss)
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))
)|;
(defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)
;; return a list of lists grouped by 3 from a flat list
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)))
(reverse new)
)
;;=====================================
;; return a list of intersect points
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone)
))))))
iplist
)
)
;;========================================
;; Break entity at break points in list
;;========================================
;; New as per version 1.8 [BrkGap] --- This subroutine has been re-written
;; Loop through the break points breaking the entity
;; If the entity is not a closed entity then a new object is created
;; This object is added to a list. When break points don't fall on the current
;; entity the list of new entities are searched to locate the entity that the
;; point is on so it can be broken.
;; "Break with a Gap" has been added to this routine. The problem faced with
;; this method is that sections to be removed may lap if the break points are
;; too close to each other. The solution is to create a list of break point pairs
;; representing the gap to be removed and test to see if there i an overlap. If
;; there is then merge the break point pairs into one large gap. This way the
;; points will always fall on an object with one exception. If the gap is too near
;; the end of an object one break point will be off the end and therefore that
;; point will need to be replaced with the end point.
;; NOTE: in ACAD2000 the (vlax-curve-getdistatpoint function has proven unreliable
;; so I have used (vlax-curve-getdistatparam in most cases
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
brkptE brkpt result GapFlg result ignore dist tmppt
#ofpts 2gap enddist lastent obj2break stdist
)
(or BrkGap (setq BrkGap 0.0)) ; default to 0
(setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point
(setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
GapFlg (not (zerop BrkGap)) ; gap > 0
closedobj (vlax-curve-isclosed obj2break)
)
;; when zero gap no need to break at end points, not closed
(if (and (zerop Brkgap)(not closedobj)) ; Revision 2.2
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)))
brkptlst)
)
)
(if brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break x))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break x))))))
) brkptlst))
;; sort primary list on distance
(setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))
(if GapFlg ; gap > 0
;; Brkptlst starts as the break point and then a list of pairs of points
;; is creates as the break points
(progn
;; create a list of list of break points
;; ((idx# stpoint distance)(idx# endpoint distance)...)
(setq idx 0)
(foreach brkpt brkptlst
;; ----------------------------------------------------------
;; create start break point, then create end break point
;; ((idx# startpoint distance)(idx# endpoint distance)...)
;; ----------------------------------------------------------
(setq dist (cadr brkpt)) ; distance to center of gap
;; subtract gap to get start point of break gap
(cond
((and (minusp (setq stDist (- dist BrkGap))) closedobj )
(setq stdist (+ (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)) stDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((minusp stDist) ; off start of object so get startpoint
(setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; add gap to get end point of break gap
(cond
((and (> (setq stDist (+ dist BrkGap))
(setq endDist (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)))) closedobj )
(setq stdist (- stDist endDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((> stDist endDist) ; off end of object so get endpoint
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getendparam obj2break))
endDist) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; -------------------------------------------------------
(setq idx (1+ IDX))
) ; foreach brkpt brkptlst
(setq dlst (reverse dlst))
;; remove the points of the gap segments that overlap
(setq idx -1
2gap (* BrkGap 2)
#ofPts (length Brkptlst)
)
(while (<= (setq idx (1+ idx)) #ofPts)
(cond
((null result) ; 1st time through
(setq result (list (car dlst)) ; get first start point
result (cons (nth (1+(* idx 2)) dlst) result))
)
((= idx #ofPts) ; last pass, check for wrap
(if (and closedobj (> #ofPts 1)
(<= (+(- (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break))
(cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
(progn
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (cadr (reverse result)) result) ; get last end point
result (cdr (reverse result))
result (reverse (cdr result)))
)
)
)
;; Break Gap Overlaps
((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point
)
;; Break Gap does Not Overlap previous point
(t
(setq result (cons (nth (* idx 2) dlst) result)) ; get this start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point
)
) ; end cond stmt
) ; while
;; setup brkptlst with pair of break pts ((p1 p2)(p3 p4)...)
;; one of the pair of points will be on the object that
;; needs to be broken
(setq dlst (reverse result)
brkptlst nil)
(while dlst ; grab the points only
(setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
dlst (cddr dlst))
)
)
)
;; -----------------------------------------------------
;; (if (equal a ent) (princ)) ; debug CAB -------------
(foreach brkpt (reverse brkptlst)
(if GapFlg ; gap > 0
(setq brkptS (car brkpt)
brkptE (cadr brkpt))
(setq brkptS (car brkpt)
brkptE brkptS)
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj2break tmppt))))
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while (and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj tmppt)))
(null (setq obj2break obj)) ; switch objects, null causes exit
t
)
)
)
)
)
)
)
;| ;; ver 2.0 fix - removed this code as there are cases where the break point
;; is at the end of a line which is not a valid break but does no harm
(if (and brkobjlst idx (minusp idx)
(null (alert (strcat "Error - point not on object"
"\nPlease report this error to"
"\n CAB at TheSwamp.org"))))
(exit)
)
|;
;; (if (equal (if (null a)(setq a (car(entsel"\nTest Ent"))) a) ent) (princ)) ; debug CAB -------------
;; Handle any objects that can not be used with the Break Command
;; using one point, gap of 0.000001 is used
(setq closedobj (vlax-curve-isclosed obj2break))
(if GapFlg ; gap > 0
(if closedobj
(progn ; need to break a closed object
(setq brkpt2 (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
(command "._break" obj2break "_non" (trans brkpt2 0 1)
"_non" (trans brkptE 0 1))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(setq BrkptE brkpt2)
)
)
;; single breakpoint ----------------------------------------------------
;|(if (and closedobj ; problems with ACAD200 & this code
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001))))
)
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001)))
)|;
(if (and closedobj
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))))
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
)
) ; endif
;; (if (null brkptE) (princ)) ; debug
(setq LastEnt (GetLastEnt))
(command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
(and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast))))
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
) ; endif brkptlst
) ; defun break_obj
;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt ( / ename result )
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;===================================
;; CAB - return a list of new enames
(defun GetNewEntities (ename / new)
(cond
((null ename) (alert "Ename nil"))
((eq 'ENAME (type ename))
(while (setq ename (entnext ename))
(if (entget ename) (setq new (cons ename new)))
)
)
((alert "Ename wrong type."))
)
new
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(setq LastEntInDatabase (GetLastEnt))
(if (and ss2brk ss2brkwith)
(progn
(setq oc 0
ss2brkwithList (ssget->vla-list ss2brkwith))
(if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)
(setq *BrkVerbose* t)
)
(and *BrkVerbose*
(princ (strcat "Objects to be Checked: "
(itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))
;; CREATE a list of entity & it's break points
(foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk
(if (not (onlockedlayer (vlax-vla-object->ename obj)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(foreach intobj ss2brkwithList
(if (and (or self (not (equal obj intobj)))
(setq intpts (get_interpts obj intobj))
)
(setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
)
(and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))
)
(if lst
(setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
)
)
)
)
(and *BrkVerbose* (princ "\nBreaking Objects.\n"))
(setq *brkcnt* 0) ; break counter
;; masterlist = ((ent brkpts)(ent brkpts)...)
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk) Gap)
)
)
)
)
;;==============================================================
(and (zerop *brkcnt*) (princ "\nNone to be broken."))
(setq *BrkVerbose* nil)
(GetNewEntities LastEntInDatabase) ; return list of enames of new objects
)
Message 4 of 4
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Here is my Flatten Program and it is powerful and fast on big files sizes.
