• Add-On’s
  • Download
  • History of AutoLISP
  • Lisp Resources
  • Run an AutoLISP

LispBox

~ This blog was initially created for people, who love autolisp routines, as I love it.

Monthly Archives: August 2019

Draw rotated rectangle and hatch it by “paper background” color (improved version)

29 Thursday Aug 2019

Posted by danglar71 in Hatch

≈ Leave a comment


;;; Draw rotated rectangle and hatch it by "paper background" color
;;; Created by Igal Averbuh 2019 (improved draworder and osnap settings)
;;; Based on Lee Mak routines (draw rotated rectangle)

;;;====================================================================;
;;; SetCurrent.lsp ;
;;; Charles Alan Butler ;
;;; ab2draft@TampaBay.rr.com ;
;;; @ Copyright 2005 ;
;;; Original routine 2003 ;
;;;====================================================================;
;;
;; Revision 06/17/04
;; Revision 06/28/04
;; Added Leader detection & layer change for any object selected.
;; Revision 07/03/04
;; Added cross check for leader to text & text to leader
;;
;; Routine to set current Layer, Text Style and/or Dim Style by
;; picking an existing object in the drawing
;;
;; OBJECT SELECTED Set Current
;; TEXT, MTEXT or Rtext Layer, Text Style
;; Dimension Layer, Dim Style
;; Leader Layer, Dim Style
;; Leader w/text Layer, Dim & Text Style
;; Text, mtext w/Leader Layer, Dim & Text Style
;; Any other object Layer
;;
;; Enter tds from the command line to run
;; or set up a menu button with ^C^Ctds
;;
;;;====================================================================;
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED ;
;;; WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR ;
;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED. ;
;;;====================================================================;
;;; Copyright 2005 by Charles Alan Butler. All Rights Reserved. ;
;;; ;
;;; You are hereby granted permission to use, copy and modify this ;
;;; software without charge, provided you do so exclusively for ;
;;; your own use or for use by others in your organization in the ;
;;; performance of their normal duties, and provided further that ;
;;; the above copyright notice appears in all copies and both that ;
;;; copyright notice and the limited warranty and restricted rights ;
;;; notice below appear in all supporting documentation. ;
;;; ;
;;; Incorporation of any part of this software into other software, ;
;;; except when such incorporation is exclusively for your own use ;
;;; or for use by others in your organization in the performance of ;
;;; their normal duties, is prohibited without the prior written ;
;;; consent of Charles Alan Butler, 1403 Duelda Drive, ;
;;; Brandon Florida, 33511 ;
;;; ;
;;; Copying, modification and distribution of this software or any ;
;;; part thereof in any form except as expressly provided herein is ;
;;; prohibited without the prior written consent of Charles Alan ;
;;; Butler, 1403 Duelda Drive, Brandon Florida, 33511 ;
;;; ;
;;;====================================================================;
(defun c:tds (/ ent entbl t:styold t:stynew d:styold d:stynew usercmd
idx x )
(defun set:dim:style (elst)
(setq d:styold (getvar "dimstyle"))
(command "-dimstyle" "restore" (cdr (assoc 3 elst)))
(setq d:stynew (getvar "dimstyle"))
)
(defun set:txt:style (elst)
(setq t:stynew (cdr (assoc 7 elst))
t:styold (getvar "textstyle")
)
(setvar "TextSize" (cdr (assoc 40 elst)))
(setvar "TextStyle" t:stynew)
)
;; ************** Begin Routine ******************
(if (setq ent
(car (entsel "\nSelect Object to make layer current (Enter to None): "))
)
(progn
(setq entbl (entget ent)) ; Get entity definition list
(setq usercmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "undo" "begin")
(cond
;; ============================================================
((= (cdr (assoc 0 entbl)) "LEADER") ; found a leader
(setvar 'clayer (cdr (assoc 8 entbl)))
(set:dim:style entbl); Set Dim Style Current
(cond ; chek to see if text is attched
((and (setq elst (entget(cdr (assoc 340 entbl))))
(wcmatch (cdr (assoc 0 elst)) "*TEXT*"))
(set:txt:style elst); Set TextStyle Current
)
)
); end cond 1

;; ===========================================================
((wcmatch (cdr (assoc 0 entbl)) "*TEXT*") ; gets Rtext as well
(set:txt:style entbl); Set TextStyle Current
(setvar 'clayer (cdr (assoc 8 entbl)))
;; Look for leader to set dim Style Current
(setq idx (length entbl))
(while (> (setq idx (1- idx))-1)
(setq ent (nth idx entbl))
(cond
((and (= (car ent) 330) ; pointer to leader
(setq elst (entget (cdr ent))) ; valid ent ??
(= (cdr (assoc 0 elst)) "LEADER"))
(set:dim:style entbl); Set Dim Style Current
(setq idx 0); 0 = exit loop
); cond
); cond stmt
); while
) ; end cond 2

;; =============================================================
((= (cdr (assoc 0 entbl)) "DIMENSION")
(set:dim:style entbl); Set Dim Style Current
(setvar 'clayer (cdr (assoc 8 entbl)))
) ; end cond 3

;; =============================================================
(t ; catch any other object
(and (cdr (assoc 8 entbl))
(setvar 'clayer (cdr (assoc 8 entbl)))
)
) ; end cond (T)

) ; end Cond stmt
;; *************** Display Changes Made *******************
(prompt (strcat "\n*-* Object selected: " (cdr (assoc 0 entbl))))
(and (cdr (assoc 8 entbl))
(prompt (strcat "\n*-* Layer changed to: " (cdr (assoc 8 entbl)))))
(if d:styold
(prompt (strcat "\n*-* Dimension style changed: "
d:styold " to "
d:stynew "."
)
)
)
(if t:styold
(prompt
(strcat "\n*-* Text style changed: " t:styold " to " t:stynew ".")
)
)
(setq t:stynew nil
t:styold nil
d:stynew nil
d:styold nil
)

(command "undo" "end")
(setvar "CMDECHO" usercmd)
) ; end progn
) ; endif
(princ)
) ;End of Defun
;(prompt "\nText / Dimension Style Changer Loaded, Type TDS to run")
(princ)

(defun c:raa ( / nv oc p1 p2 p3 p4 p5 pl p5a os AScol ASsize )
(if
(and
(setq p1 (getpoint "\n1st point: "))
(setq p2 (getpoint "\n2nd point: " p1))
)
(progn
(setq nv (trans (mapcar '- p2 p1) 1 0 t)
oc (trans '(0.0 0.0 1.0) 1 0 t)
p3 (trans p1 1 nv)
p4 (trans p2 1 nv)
)

;AutoSnap marker color
(setq AScol (LM:OLE->RGB (atoi (getenv "Model AutoSnap Color"))))
(setq AScol (LM:RGB->ACI (car AScol) (cadr AScol) (caddr AScol)))

;AutoSnap marker size
(setq ASsize (* (atoi (getenv "AutoSnapSize")) 0.002))

(princ "\n3rd point: ")
(while (= 5 (car (setq p5 (grread t 13 0))))
(redraw)
(and (setq os (osmode2str)) (setq p5a (osnap (cadr p5) os)))
(if p5a
(progn
(ASvector p5a AScol)
(setq p5a (trans p5a 1 nv))
(mapcar '(lambda ( a b ) (grdraw a b 1 1))
(setq pl
(list p1 p2
(trans (list (car p5a) (cadr p5a) (caddr p4)) nv 1)
(trans (list (car p5a) (cadr p5a) (caddr p3)) nv 1)
)
)
(cons (last pl) pl)
)
)
(progn
(setq p5 (trans (cadr p5) 1 nv))
(mapcar '(lambda ( a b ) (grdraw a b 1 1))
(setq pl
(list p1 p2
(trans (list (car p5) (cadr p5) (caddr p4)) nv 1)
(trans (list (car p5) (cadr p5) (caddr p3)) nv 1)
)
)
(cons (last pl) pl)
)
)
)
)
(if
(and
(listp (cadr p5))
(setq p5 (trans (cadr p5) 1 nv))
)
(progn
(and p5a (setq p5 p5a))
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans p1 1 oc))
(cons 010 (trans p2 1 oc))
(cons 010 (trans (list (car p5) (cadr p5) (caddr p4)) nv oc))
(cons 010 (trans (list (car p5) (cadr p5) (caddr p3)) nv oc))
(cons 210 oc)
)
)
)
)
(redraw)
)
)
(princ)
)

;----------------------------------------------------------
; Return the current osnap mode in the form of a string.
; i.e.: osmode = 37 --> "_end,_cen,_int"
; Gian Paolo Cattaneo - 09/11/2013
;----------------------------------------------------------
(defun osmode2str ( / osm)
(if (> (getvar 'osmode) 0)
(mapcar
'(lambda (a b)
(if (= a (logand a (getvar 'osmode)))
(if osm
(setq osm (strcat osm "," b))
(setq osm b)
)
)
)
'(1 2 4 8 16 32 64 128 256 512)
'("_end" "_mid" "_cen" "_nod" "_qua"
"_int" "_ins" "_per" "_tan" "_nea"
)
)
)
osm
)

;----------------------------------------------------------
;; OLE -> RGB - Lee Mac 2011
;; Args: c - OLE Colour
;----------------------------------------------------------
(defun LM:OLE->RGB ( c )
(list
(lsh (lsh (fix c) 24) -24)
(lsh (lsh (fix c) 16) -24)
(lsh (lsh (fix c) 8) -24)
)
)

;----------------------------------------------------------
;; RGB -> ACI - Lee Mac 2011
;; Args: r,g,b - Red,Green,Blue values
;----------------------------------------------------------
(defun LM:RGB->ACI ( r g b / cObj aci ) (vl-load-com)
(if
(and
(setq cObj
(vla-getInterfaceObject (vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
)
)
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-SetRGB (list cObj r g b))
)
)
)
(setq aci (vla-get-ColorIndex cObj))
)
(if cObj (vlax-release-object cObj))
aci
)

;_____________________credit: ronjonp______________________
(defun ASvector (pt: color / L L- c1 c2 *1 *2 *3 *4 *5 *6
*7 *8 *9 *10 *11 *12)
(setq L (* (* 1.3 ASsize) (getvar 'viewsize))
L- (* 0.9 L)
c1 (polar pt: pi (* L 0.06))
c2 (polar pt: 0.0 (* L 0.06))
*1 (polar c1 0.785 L)
*2 (polar c1 2.356 L-)
*3 (polar c1 3.926 L-)
*4 (polar c1 5.498 L)
*5 (polar c2 0.785 L-)
*6 (polar c2 2.356 L)
*7 (polar c2 3.926 L)
*8 (polar c2 5.498 L-)
*9 (polar pt: 0.785 L)
*10 (polar pt: 2.356 L)
*11 (polar pt: 3.926 L)
*12 (polar pt: 5.498 L)
)
(grvecs (list color *2 *5 *3 *8 *6 *7 *1 *4))
(grvecs (list color *9 *10 *11 *12 *9 *12 *10 *11))
(grvecs (list color *1 *3 *2 *4 *5 *7 *6 *8 *9 *11 *10 *12))
)

;;************

(defun c:cross (/ )

(command "-hatch" "p" "s" "")
(command "-hatch" "s" "l" "" "p" "s" "co" "t" "255,255,255" "" )
(command "draworder" "l" "" "b")
(c:os)

);defun
(princ)

(DEFUN c:xrb ( / curent curset newset)
(vl-load-com)
(command "._TILEMODE" "1")
(SETQ newset (SSADD))
(IF (SETQ curset (SSGET "X" '((0 . "INSERT"))))
(WHILE (SETQ curent (SSNAME curset 0))
(SETQ curobj (VLAX-ENAME->VLA-OBJECT curent))
(IF (= T (VLAX-PROPERTY-AVAILABLE-P curobj 'path))
(SSADD curent newset)
)
(SSDEL curent curset)
)
)
(command "_.draworder" newset "" "_b")
)

(defun c:h ( )
(setvar "osmode" 0)
(c:tds)
(setvar "osmode" 0)
(c:raa)
(setvar "osmode" 0)
(c:cross)
(setvar "osmode" 0)
(c:xrb)
(setvar "osmode" 167)
)
(c:h)

Draw rotated rectangle and wipeout it (improved version)

29 Thursday Aug 2019

Posted by danglar71 in Hatch

≈ Leave a comment


;;; Draw rotated rectangle and wipeout it
;;; Created by Igal Averbuh 2019 (improved draworder and osnap settings)
;;; Based on Lee Mak routines (draw rotated rectangle)

;;;====================================================================;
;;; SetCurrent.lsp ;
;;; Charles Alan Butler ;
;;; ab2draft@TampaBay.rr.com ;
;;; @ Copyright 2005 ;
;;; Original routine 2003 ;
;;;====================================================================;
;;
;; Revision 06/17/04
;; Revision 06/28/04
;; Added Leader detection & layer change for any object selected.
;; Revision 07/03/04
;; Added cross check for leader to text & text to leader
;;
;; Routine to set current Layer, Text Style and/or Dim Style by
;; picking an existing object in the drawing
;;
;; OBJECT SELECTED Set Current
;; TEXT, MTEXT or Rtext Layer, Text Style
;; Dimension Layer, Dim Style
;; Leader Layer, Dim Style
;; Leader w/text Layer, Dim & Text Style
;; Text, mtext w/Leader Layer, Dim & Text Style
;; Any other object Layer
;;
;; Enter tds from the command line to run
;; or set up a menu button with ^C^Ctds
;;
;;;====================================================================;
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED ;
;;; WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR ;
;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED. ;
;;;====================================================================;
;;; Copyright 2005 by Charles Alan Butler. All Rights Reserved. ;
;;; ;
;;; You are hereby granted permission to use, copy and modify this ;
;;; software without charge, provided you do so exclusively for ;
;;; your own use or for use by others in your organization in the ;
;;; performance of their normal duties, and provided further that ;
;;; the above copyright notice appears in all copies and both that ;
;;; copyright notice and the limited warranty and restricted rights ;
;;; notice below appear in all supporting documentation. ;
;;; ;
;;; Incorporation of any part of this software into other software, ;
;;; except when such incorporation is exclusively for your own use ;
;;; or for use by others in your organization in the performance of ;
;;; their normal duties, is prohibited without the prior written ;
;;; consent of Charles Alan Butler, 1403 Duelda Drive, ;
;;; Brandon Florida, 33511 ;
;;; ;
;;; Copying, modification and distribution of this software or any ;
;;; part thereof in any form except as expressly provided herein is ;
;;; prohibited without the prior written consent of Charles Alan ;
;;; Butler, 1403 Duelda Drive, Brandon Florida, 33511 ;
;;; ;
;;;====================================================================;
(defun c:tds (/ ent entbl t:styold t:stynew d:styold d:stynew usercmd
idx x )
(defun set:dim:style (elst)
(setq d:styold (getvar "dimstyle"))
(command "-dimstyle" "restore" (cdr (assoc 3 elst)))
(setq d:stynew (getvar "dimstyle"))
)
(defun set:txt:style (elst)
(setq t:stynew (cdr (assoc 7 elst))
t:styold (getvar "textstyle")
)
(setvar "TextSize" (cdr (assoc 40 elst)))
(setvar "TextStyle" t:stynew)
)
;; ************** Begin Routine ******************
(if (setq ent
(car (entsel "\nSelect Object to make layer current (Enter to None): "))
)
(progn
(setq entbl (entget ent)) ; Get entity definition list
(setq usercmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "undo" "begin")
(cond
;; ============================================================
((= (cdr (assoc 0 entbl)) "LEADER") ; found a leader
(setvar 'clayer (cdr (assoc 8 entbl)))
(set:dim:style entbl); Set Dim Style Current
(cond ; chek to see if text is attched
((and (setq elst (entget(cdr (assoc 340 entbl))))
(wcmatch (cdr (assoc 0 elst)) "*TEXT*"))
(set:txt:style elst); Set TextStyle Current
)
)
); end cond 1

;; ===========================================================
((wcmatch (cdr (assoc 0 entbl)) "*TEXT*") ; gets Rtext as well
(set:txt:style entbl); Set TextStyle Current
(setvar 'clayer (cdr (assoc 8 entbl)))
;; Look for leader to set dim Style Current
(setq idx (length entbl))
(while (> (setq idx (1- idx))-1)
(setq ent (nth idx entbl))
(cond
((and (= (car ent) 330) ; pointer to leader
(setq elst (entget (cdr ent))) ; valid ent ??
(= (cdr (assoc 0 elst)) "LEADER"))
(set:dim:style entbl); Set Dim Style Current
(setq idx 0); 0 = exit loop
); cond
); cond stmt
); while
) ; end cond 2

;; =============================================================
((= (cdr (assoc 0 entbl)) "DIMENSION")
(set:dim:style entbl); Set Dim Style Current
(setvar 'clayer (cdr (assoc 8 entbl)))
) ; end cond 3

;; =============================================================
(t ; catch any other object
(and (cdr (assoc 8 entbl))
(setvar 'clayer (cdr (assoc 8 entbl)))
)
) ; end cond (T)

) ; end Cond stmt
;; *************** Display Changes Made *******************
(prompt (strcat "\n*-* Object selected: " (cdr (assoc 0 entbl))))
(and (cdr (assoc 8 entbl))
(prompt (strcat "\n*-* Layer changed to: " (cdr (assoc 8 entbl)))))
(if d:styold
(prompt (strcat "\n*-* Dimension style changed: "
d:styold " to "
d:stynew "."
)
)
)
(if t:styold
(prompt
(strcat "\n*-* Text style changed: " t:styold " to " t:stynew ".")
)
)
(setq t:stynew nil
t:styold nil
d:stynew nil
d:styold nil
)

(command "undo" "end")
(setvar "CMDECHO" usercmd)
) ; end progn
) ; endif
(princ)
) ;End of Defun
;(prompt "\nText / Dimension Style Changer Loaded, Type TDS to run")
(princ)

(defun c:raa ( / nv oc p1 p2 p3 p4 p5 pl p5a os AScol ASsize )
(if
(and
(setq p1 (getpoint "\n1st point: "))
(setq p2 (getpoint "\n2nd point: " p1))
)
(progn
(setq nv (trans (mapcar '- p2 p1) 1 0 t)
oc (trans '(0.0 0.0 1.0) 1 0 t)
p3 (trans p1 1 nv)
p4 (trans p2 1 nv)
)

;AutoSnap marker color
(setq AScol (LM:OLE->RGB (atoi (getenv "Model AutoSnap Color"))))
(setq AScol (LM:RGB->ACI (car AScol) (cadr AScol) (caddr AScol)))

;AutoSnap marker size
(setq ASsize (* (atoi (getenv "AutoSnapSize")) 0.002))

(princ "\n3rd point: ")
(while (= 5 (car (setq p5 (grread t 13 0))))
(redraw)
(and (setq os (osmode2str)) (setq p5a (osnap (cadr p5) os)))
(if p5a
(progn
(ASvector p5a AScol)
(setq p5a (trans p5a 1 nv))
(mapcar '(lambda ( a b ) (grdraw a b 1 1))
(setq pl
(list p1 p2
(trans (list (car p5a) (cadr p5a) (caddr p4)) nv 1)
(trans (list (car p5a) (cadr p5a) (caddr p3)) nv 1)
)
)
(cons (last pl) pl)
)
)
(progn
(setq p5 (trans (cadr p5) 1 nv))
(mapcar '(lambda ( a b ) (grdraw a b 1 1))
(setq pl
(list p1 p2
(trans (list (car p5) (cadr p5) (caddr p4)) nv 1)
(trans (list (car p5) (cadr p5) (caddr p3)) nv 1)
)
)
(cons (last pl) pl)
)
)
)
)
(if
(and
(listp (cadr p5))
(setq p5 (trans (cadr p5) 1 nv))
)
(progn
(and p5a (setq p5 p5a))
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans p1 1 oc))
(cons 010 (trans p2 1 oc))
(cons 010 (trans (list (car p5) (cadr p5) (caddr p4)) nv oc))
(cons 010 (trans (list (car p5) (cadr p5) (caddr p3)) nv oc))
(cons 210 oc)
)
)
)
)
(redraw)
)
)
(princ)
)

;----------------------------------------------------------
; Return the current osnap mode in the form of a string.
; i.e.: osmode = 37 --> "_end,_cen,_int"
; Gian Paolo Cattaneo - 09/11/2013
;----------------------------------------------------------
(defun osmode2str ( / osm)
(if (> (getvar 'osmode) 0)
(mapcar
'(lambda (a b)
(if (= a (logand a (getvar 'osmode)))
(if osm
(setq osm (strcat osm "," b))
(setq osm b)
)
)
)
'(1 2 4 8 16 32 64 128 256 512)
'("_end" "_mid" "_cen" "_nod" "_qua"
"_int" "_ins" "_per" "_tan" "_nea"
)
)
)
osm
)

;----------------------------------------------------------
;; OLE -> RGB - Lee Mac 2011
;; Args: c - OLE Colour
;----------------------------------------------------------
(defun LM:OLE->RGB ( c )
(list
(lsh (lsh (fix c) 24) -24)
(lsh (lsh (fix c) 16) -24)
(lsh (lsh (fix c) 8) -24)
)
)

;----------------------------------------------------------
;; RGB -> ACI - Lee Mac 2011
;; Args: r,g,b - Red,Green,Blue values
;----------------------------------------------------------
(defun LM:RGB->ACI ( r g b / cObj aci ) (vl-load-com)
(if
(and
(setq cObj
(vla-getInterfaceObject (vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
)
)
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-SetRGB (list cObj r g b))
)
)
)
(setq aci (vla-get-ColorIndex cObj))
)
(if cObj (vlax-release-object cObj))
aci
)

;_____________________credit: ronjonp______________________
(defun ASvector (pt: color / L L- c1 c2 *1 *2 *3 *4 *5 *6
*7 *8 *9 *10 *11 *12)
(setq L (* (* 1.3 ASsize) (getvar 'viewsize))
L- (* 0.9 L)
c1 (polar pt: pi (* L 0.06))
c2 (polar pt: 0.0 (* L 0.06))
*1 (polar c1 0.785 L)
*2 (polar c1 2.356 L-)
*3 (polar c1 3.926 L-)
*4 (polar c1 5.498 L)
*5 (polar c2 0.785 L-)
*6 (polar c2 2.356 L)
*7 (polar c2 3.926 L)
*8 (polar c2 5.498 L-)
*9 (polar pt: 0.785 L)
*10 (polar pt: 2.356 L)
*11 (polar pt: 3.926 L)
*12 (polar pt: 5.498 L)
)
(grvecs (list color *2 *5 *3 *8 *6 *7 *1 *4))
(grvecs (list color *9 *10 *11 *12 *9 *12 *10 *11))
(grvecs (list color *1 *3 *2 *4 *5 *7 *6 *8 *9 *11 *10 *12))
)

;;************

(defun c:cross1 (/ )

(command "wipeout" "p" "l" "y")

(command "draworder" "l" "" "b")
(c:os)

);defun
(princ)

(DEFUN c:xrb ( / curent curset newset)
(vl-load-com)
(command "._TILEMODE" "1")
(SETQ newset (SSADD))
(IF (SETQ curset (SSGET "X" '((0 . "INSERT"))))
(WHILE (SETQ curent (SSNAME curset 0))
(SETQ curobj (VLAX-ENAME->VLA-OBJECT curent))
(IF (= T (VLAX-PROPERTY-AVAILABLE-P curobj 'path))
(SSADD curent newset)
)
(SSDEL curent curset)
)
)
(command "_.draworder" newset "" "_b")
)

(defun c:w ( )
(setvar "osmode" 0)
(c:tds)
(setvar "osmode" 0)
(c:raa)
(setvar "osmode" 0)
(c:cross1)
(c:xrb)
(setvar "osmode" 167)
)
(c:w)

Offset Nested Lines and Polylines in a one click change it width and convert it to red color

29 Thursday Aug 2019

Posted by danglar71 in Utilites

≈ Leave a comment


;;; Offset Nested Lines and Polylines in a one click change it width and convert it to red color
;;; Modified by Igal Averbuh 2019 (added option to change width of ncopied polylines + offset by Kent Cooper subroutine)
;;; Inspired by dbhunia and Kent Cooper subrroutines
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/ncopy-multiple-elements-and-convert-them-to-cyan-color/td-p/8301579
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/offset-last-entity/td-p/2604367

(defun c:no (/ lastent ss)
(setq lastent (entlast))
(setq ss (ssadd))
(command "_.ncopy")
(while (> (getvar "cmdactive") 0)
(command pause "0,0" "0,0")
)
(while (setq lastent (entnext lastent))
(ssadd lastent ss)

)
(command "chprop" ss "" "C" 1 "")
(command "pedit" "m" ss "" "w" 0.15 "")
(setq ent (entlast))

(command
"_.offset"
"T"
ent
pause ; select side
""
)
(entdel ent)
)

Creating table with selected text

21 Wednesday Aug 2019

Posted by danglar71 in Lisp Collection 2014, Utilites

≈ Leave a comment


;;; Creating table with selected text
;;; Created by sea.haven
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-for-creating-table-with-selected-text/td-p/8954787
;;; Slightly modified by Igal Averbuh 2019 (added option fo set text size by 2 points on screen)

(defun c:mtl ( / pt1 numrows numcolumns rowheight colwidth ent doc curspace obj objtable col)
(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(setq curspace (vla-get-modelspace doc))
; now do table
(setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table: ")))
(setq numcolumns (getint "\nHow many columns..."))
(setq numrows 2)
(setq txtsz (getdist "\nEnter text size by 2 points on screen..."))

(setq rowheight (* 1.5 txtsz))
(setq colwidth (* 10 txtsz))
(setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "TABLE")
(setq x 1)
(repeat numcolumns
(vla-settext objtable 1 (- x 1) (strcat "COLUMN " (rtos x 2 0)))
(setq x (+ x 1))
)

(setq objtable (vlax-ename->vla-object (entlast)))
(vla-InsertRows objtable numrows txtsz 1)
(setq col 0)
(while (setq ent (entsel "pick text object"))
(setq obj (vlax-ename->vla-object (car ent)))
(if (= (vla-get-objectname obj) "AcDbText")
(progn
(vla-settext objtable numrows col (vla-get-textstring obj))
(setq col (+ col 1))
(if (= col numcolumns)
(progn
(setq col 0)
(setq numrows (+ numrows 1))
(vla-InsertRows objtable numrows (* txtsz 1.5) 1)
)
)
)
)
)

(vla-SetTextHeight objtable (+ acDataRow acHeaderRow acTitleRow) txtsz)
(vla-SetAlignment objtable acDataRow acMiddleCenter)
(vlax-release-object objtable)
(princ)
)

(c:mtl)

Select (activate) viewport inside another viewport in one click

20 Tuesday Aug 2019

Posted by danglar71 in Vport

≈ Leave a comment


;;; Select (activate) viewport inside another viewport in one click
;;; Created by cwake
;;; Saved from: https://www.cadtutor.net/forum/topic/59734-alternate-method-for-activating-floating-viewports/

(defun c:vv ( /
; Functions
gvpbs insidep1 insidep2 vlax-list->3D-point
; Variables
doc vps pt vp
)

(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
;;******************************************************************
;; Local Functions
;;******************************************************************
(defun gvpbs ( / vps i el cb bdys ctr v )
(if (setq vps (ssget
"_X"
(list
'(0 . "VIEWPORT")
'(-4 . ">")
'(69 . 1)
(cons 410 (getvar "CTAB"))
)
)
)
(progn
(repeat (setq i (sslength vps))
(setq el (entget (ssname vps (setq i (1- i)))))
(if (setq cb (cdr (assoc 340 el)))
(setq bdys (cons (cons cb (cdr (assoc 69 el))) bdys))
(progn
(setq ctr (cdr (assoc 10 el))
v (list
(/ (cdr (assoc 40 el)) 2.)
(/ (cdr (assoc 41 el)) 2.)
0.0
)
bdys (cons
(cons
(list
(mapcar '- ctr v)
(mapcar '+ ctr v)
)
(cdr (assoc 69 el))
)
bdys
)
)
)
)
)
bdys
)
)
)

;;******************************************************************
;; from [url]http://www.cadtutor.net/forum/showthread.php?36221-How-to-determine-if-a-point-is-within-a-boundary[/url]
;; ============ Insidep.lsp ===============
;;
;; MAIN FUNCTION DESCRIPTION:
;; Will determine whether a point lies
;; inside or outside an object.
;;
;; FUNCTION: insidep
;; ARGUMENTS:
;; Point to be tested.
;; Object Ename or VLA-Object
;;
;; FUNCTION: vlax-list->3D-point
;; ARGUMENTS:
;; List to be converted.
;; Flag to determine x or y.
;;
;; OBJECT COMPATIBILITY:
;; Everything except Viewport/Polygon Mesh.
;;
;; AUTHOR:
;; Copyright (c) 2009, Lee McDonnell
;; (Contact Lee Mac, CADTutor.net)
;;
;; PLATFORMS:
;; No Restrictions,
;; only tested in ACAD 2004.
;;
;; ========================================

(defun insidep1 ( pt Obj / Tol ang spc flag int lin xV yV )
(or (eq 'VLA-OBJECT (type Obj))
(setq Obj (vlax-ename->vla-object Obj)))

(setq Tol (/ pi 6) ; Uncertainty
ang 0.0 flag T)

(setq spc (if (zerop (vla-get-activespace doc))
(if (= (vla-get-mspace doc) :vlax-true)
(vla-get-modelspace doc)
(vla-get-paperspace doc))
(vla-get-modelspace doc)))

(while (and (< ang (* 2 pi)) flag)
(setq flag (and
(setq int
(vlax-invoke
(setq lin
(vla-addLine spc
(vlax-3D-point pt)
(vlax-3D-point
(polar pt ang
(if (vlax-property-available-p Obj 'length)
(vla-get-length Obj) 1.0)))))
'IntersectWith Obj
acExtendThisEntity))
(3D-point int T) '3D-point int nil) '<))
(or (<= (car xV) (car pt) (last xV))
(3D-point (lst flag)
(if lst
(cons ((if flag car cadr) lst)
(vlax-list->3D-point (cdddr lst) flag)
)
)
)

;;******************************************************************
(defun insidep2 ( pt lst )
(vl-every
(function
(lambda ( a )
(apply ' (getvar "CVPORT") 1) (vla-put-mspace doc :vlax-false)))
((null (setq pt (getpoint "\nSelect point inside a viewport: "))))
(T
(setq pt (trans pt 1 0))
(if (setq vp (vl-some
(function
(lambda ( x )
(if
(apply
(if (= (type (car x)) 'ENAME)
'insidep1
'insidep2
)
(list pt (car x))
)
(cdr x)
)
)
)
vps
)
)
(progn
(vla-put-mspace doc :vlax-true)
(setvar "CVPORT" vp)
)
(princ "\nPoint is not within a viewport.")
)
)
)
(princ)
)

(c:vv)

AutoCAD Command Prefixes

20 Tuesday Aug 2019

Posted by danglar71 in Tips (English)

≈ Leave a comment

What prefixes are available for AutoCAD commands?

A - answer You can use prefix characters with most AutoCAD internal commands. Such prefixes are e.g.:

  • "'" transparency prefix (invokes a command during execution of another command – e.g. ‘_HELP)
  • "-" commandline prefix (invokes a non-dialog version of a command – e.g. _-LAYER)
  • "_" non-localized command prefix (original english command names in a localized version of AutoCAD – e.g. _LINE)
  • "." non-redefined command prefix (e.g. for commands undefined using _UNDEFINE, example: ._LINE or _.LINE)
  • "+" dialog tab prefix (for selecting a particular dialog tab – e.g. '._+DSETTINGS), or a special command mode (e.g. +PUBLISH)

Viewport Outline V1.3: adds two new commands: VPOL – Outline all viewports in the active Paperspace layout; VPOA – Outline all viewports in all Paperspace layouts.

20 Tuesday Aug 2019

Posted by danglar71 in Utilites, Vport

≈ Leave a comment


;;-----------------------=={ Viewport Outline }==-----------------------;;
;; ;;
;; This program allows the user to automatically generate a polyline ;;
;; in modelspace representing the outline of a selected paperspace ;;
;; viewport. ;;
;; ;;
;; The command is only available in paperspace (that is, when a ;;
;; layout tab other than the Model tab is the current layout, and no ;;
;; viewports are active). ;;
;; ;;
;; Upon issuing the command syntax 'VPO' at the AutoCAD command-line, ;;
;; the user is prompted to select a viewport for which to construct ;;
;; the viewport outline in modelspace. ;;
;; ;;
;; Following a valid selection, the boundary of the selected viewport ;;
;; is transformed appropriately to account for the position, scale, ;;
;; rotation, & orientation of the modelspace view displayed through ;;
;; the selected viewport, and a 2D polyline (LWPolyline) representing ;;
;; this transformed boundary is constructed in modelspace. ;;
;; ;;
;; The program is compatible for use with all Rectangular, Polygonal & ;;
;; Clipped Viewports (including those with Arc segments), and with all ;;
;; views & construction planes. ;;
;; ;;
;; The program also offers the ability to optionally offset the ;;
;; polyline outline to the interior of the viewport boundary by a ;;
;; predetermined number of paperspace units specified in the ;;
;; 'Program Parameters' section of the program source code. ;;
;; ;;
;; The program may also be configured to automatically apply a ;;
;; predefined set of properties (e.g. layer, colour, linetype, etc.) ;;
;; to the resulting polyline outline - these properties are also ;;
;; listed within the 'Program Parameters' section of the source code. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2015 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.0 - 2015-01-02 ;;
;; ;;
;; - First release. ;;
;;----------------------------------------------------------------------;;
;; Version 1.1 - 2016-08-11 ;;
;; ;;
;; - Program modified to account for polygonal viewports represented ;;
;; by 2D (Heavy) Polylines. ;;
;;----------------------------------------------------------------------;;
;; Version 1.2 - 2017-09-03 ;;
;; ;;
;; - Added the ability to specify an optional interior offset ;;
;; (relative to Paperspace Viewport dimensions). ;;
;; - Added default polyline properties. ;;
;;----------------------------------------------------------------------;;
;; Version 1.3 - 2019-08-12 ;;
;; ;;
;; - Restructured program as a main function accepting a viewport ;;
;; entity argument. ;;
;; - Added two additional custom commands: ;;
;; - 'vpol' - outlines all viewports in the active Paperspace layout ;;
;; - 'vpoa' - outlines all viewports in all Paperspace layouts ;;
;;----------------------------------------------------------------------;;

;;----------------------------------------------------------------------;;
;; VPO - Outline a selected viewport in the active Paperspace layout ;;
;;----------------------------------------------------------------------;;

(defun c:vpo ( / *error* sel )

(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(LM:startundo (LM:acdoc))
(cond
( (/= 1 (getvar 'cvport))
(princ "\nCommand not available in Modelspace.")
)
( (setq sel (LM:ssget "\nSelect viewport: " '("_+.:E:S" ((0 . "VIEWPORT")))))
(vpo:main (ssname sel 0))
)
)
(LM:endundo (LM:acdoc))
(princ)
)

;;----------------------------------------------------------------------;;
;; VPOL - Outline all viewports in the active Paperspace layout ;;
;;----------------------------------------------------------------------;;

(defun c:vpol ( / *error* idx sel )

(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(cond
( (/= 1 (getvar 'cvport))
(princ "\nCommand not available in Modelspace.")
)
( (setq sel (ssget "_X" (list '(0 . "VIEWPORT") '(-4 . "") '(69 . 1) (cons 410 (getvar 'ctab)))))
(LM:startundo (LM:acdoc))
(repeat (setq idx (sslength sel))
(vpo:main (ssname sel (setq idx (1- idx))))
)
(LM:endundo (LM:acdoc))
)
( (princ "\nNo viewports were found in the active layout."))
)
(princ)
)

;;----------------------------------------------------------------------;;
;; VPOA - Outline all viewports in all Paperspace layouts ;;
;;----------------------------------------------------------------------;;

(defun c:vpoa ( / *error* idx sel )

(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(cond
( (setq sel (ssget "_X" '((0 . "VIEWPORT") (-4 . "") (69 . 1) (410 . "~Model"))))
(LM:startundo (LM:acdoc))
(repeat (setq idx (sslength sel))
(vpo:main (ssname sel (setq idx (1- idx))))
)
(LM:endundo (LM:acdoc))
)
( (princ "\nNo viewports were found in any Paperspace layouts."))
)
(princ)
)

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

(defun vpo:main ( vpt / cen dpr ent lst ltp ocs ofe off tmp vpe )

(setq

;;----------------------------------------------------------------------;;
;; Program Parameters ;;
;;----------------------------------------------------------------------;;

;; Optional Interior Offset
;; Set this parameter to nil or 0.0 for no offset
off 0.0

;; Default Polyline Properties
;; Omitted properties will use current settings when the program is run
dpr
'(
(006 . "BYLAYER") ;; Linetype (must be loaded)
;(008 . "VPOutline") ;; Layer (automatically created if not present in drawing)
(039 . 0.0) ;; Thickness
(048 . 1.0) ;; Linetype Scale
(062 . 256) ;; Colour (0 = ByBlock, 256 = ByLayer)
(370 . -1) ;; Lineweight (-1 = ByLayer, -2 = ByBlock, -3 = Default, 0.3 = 30 etc.)
)

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

)

(if (setq vpt (entget vpt)
ent (cdr (assoc 340 vpt))
)
(setq lst (vpo:polyvertices ent))
(setq cen (mapcar 'list (cdr (assoc 10 vpt))
(list
(/ (cdr (assoc 40 vpt)) 2.0)
(/ (cdr (assoc 41 vpt)) 2.0)
)
)
lst (mapcar '(lambda ( a ) (cons (mapcar 'apply a cen) '(42 . 0.0))) '((- -) (+ -) (+ +) (- +)))
)
)
(if (not (LM:listclockwise-p (mapcar 'car lst)))
(setq lst (reverse (mapcar '(lambda ( a b ) (cons (car a) (cons 42 (- (cddr b))))) lst (cons (last lst) lst))))
)
(if (and (numberp off) (not (equal 0.0 off 1e-8)))
(cond
( (null
(setq tmp
(entmakex
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst))
'(070 . 1)
)
(apply 'append (mapcar '(lambda ( x ) (list (cons 10 (car x)) (cdr x))) lst))
)
)
)
)
(princ "\nUnable to generate Paperspace outline for offset.")
)
( (vl-catch-all-error-p (setq ofe (vl-catch-all-apply 'vlax-invoke (list (vlax-ename->vla-object tmp) 'offset off))))
(princ (strcat "\nViewport dimensions too small to offset outline by " (rtos off) " units."))
(entdel tmp)
)
( (setq ofe (vlax-vla-object->ename (car ofe))
lst (vpo:polyvertices ofe)
)
(entdel ofe)
(entdel tmp)
)
)
)
(setq vpe (cdr (assoc -1 vpt))
ocs (cdr (assoc 16 vpt))
)
(entmakex
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst))
'(070 . 1)
'(410 . "Model")
)
(if (and (setq ltp (assoc 6 dpr)) (not (tblsearch "ltype" (cdr ltp))))
(progn
(princ (strcat "\n\"" (cdr ltp) "\" linetype not loaded - linetype set to \"ByLayer\"."))
(subst '(6 . "BYLAYER") ltp dpr)
)
dpr
)
(apply 'append (mapcar '(lambda ( x ) (list (cons 10 (trans (pcs2wcs (car x) vpe) 0 ocs)) (cdr x))) lst))
(list (cons 210 ocs))
)
)
)

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

(defun vpo:polyvertices ( ent )
(apply '(lambda ( foo bar ) (foo bar))
(if (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
(list
(lambda ( enx )
(if (setq enx (member (assoc 10 enx) enx))
(cons (cons (cdr (assoc 10 enx)) (assoc 42 enx)) (foo (cdr enx)))
)
)
(entget ent)
)
(list
(lambda ( ent / enx )
(if (= "VERTEX" (cdr (assoc 0 (setq enx (entget ent)))))
(cons (cons (cdr (assoc 10 enx)) (assoc 42 enx)) (foo (entnext ent)))
)
)
(entnext ent)
)
)
)
)

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

;; List Clockwise-p - Lee Mac
;; Returns T if the point list is clockwise oriented

(defun LM:listclockwise-p ( lst )
(minusp
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
)
lst (cons (last lst) lst)
)
)
)
)

;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)

;; PCS2WCS (gile)
;; Translates a PCS point to WCS based on the supplied Viewport
;; (PCS2WCS pt vp) is the same as (trans (trans pt 3 2) 2 0) when vp is active
;; pnt : PCS point
;; ent : Viewport ename

(defun PCS2WCS ( pnt ent / ang enx mat nor scl )
(setq pnt (trans pnt 0 0)
enx (entget ent)
ang (- (cdr (assoc 51 enx)))
nor (cdr (assoc 16 enx))
scl (/ (cdr (assoc 45 enx)) (cdr (assoc 41 enx)))
mat (mxm
(mapcar (function (lambda ( v ) (trans v 0 nor t)))
'( (1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
(list
(list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
)
)
(mapcar '+
(mxv mat
(mapcar '+
(vxs pnt scl)
(vxs (cdr (assoc 10 enx)) (- scl))
(cdr (assoc 12 enx))
)
)
(cdr (assoc 17 enx))
)
)

;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix

(defun trp ( m )
(apply 'mapcar (cons 'list m))
)

;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices

(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)

;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n

(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

;; Vector x Scalar - Lee Mac
;; Args: v - vector in R^n, s - real scalar

(defun vxs ( v s )
(mapcar '(lambda ( n ) (* n s)) v)
)

;; Start Undo - Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)

;; End Undo - Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)

;; Active Document - Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)

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

(princ
(strcat
"\n:: VPOutline.lsp | Version 1.3 | \\U+00A9 Lee Mac "
((lambda ( y ) (if (= y (menucmd "m=$(edtime,0,yyyy)")) y (strcat y "-" (menucmd "m=$(edtime,0,yyyy)")))) "2015")
" http://www.lee-mac.com ::"
"\n:: \"vpo\" - Outline single viewport ::"
"\n:: \"vpol\" - Outline all viewports in active layout ::"
"\n:: \"vpoa\" - Outline all viewports in all layouts ::"
)
)
(princ)

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

Draw rotated rectangle and wipeout it

18 Sunday Aug 2019

Posted by danglar71 in draw

≈ Leave a comment


;;; Draw rotated rectangle and wipeout it
;;; Created by Igal Averbuh 2018
;;; Based on Lee Mak routines (draw rotated rectangle)

;;;====================================================================;
;;; SetCurrent.lsp ;
;;; Charles Alan Butler ;
;;; ab2draft@TampaBay.rr.com ;
;;; @ Copyright 2005 ;
;;; Original routine 2003 ;
;;;====================================================================;
;;
;; Revision 06/17/04
;; Revision 06/28/04
;; Added Leader detection & layer change for any object selected.
;; Revision 07/03/04
;; Added cross check for leader to text & text to leader
;;
;; Routine to set current Layer, Text Style and/or Dim Style by
;; picking an existing object in the drawing
;;
;; OBJECT SELECTED Set Current
;; TEXT, MTEXT or Rtext Layer, Text Style
;; Dimension Layer, Dim Style
;; Leader Layer, Dim Style
;; Leader w/text Layer, Dim & Text Style
;; Text, mtext w/Leader Layer, Dim & Text Style
;; Any other object Layer
;;
;; Enter tds from the command line to run
;; or set up a menu button with ^C^Ctds
;;
;;;====================================================================;
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED ;
;;; WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR ;
;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED. ;
;;;====================================================================;
;;; Copyright 2005 by Charles Alan Butler. All Rights Reserved. ;
;;; ;
;;; You are hereby granted permission to use, copy and modify this ;
;;; software without charge, provided you do so exclusively for ;
;;; your own use or for use by others in your organization in the ;
;;; performance of their normal duties, and provided further that ;
;;; the above copyright notice appears in all copies and both that ;
;;; copyright notice and the limited warranty and restricted rights ;
;;; notice below appear in all supporting documentation. ;
;;; ;
;;; Incorporation of any part of this software into other software, ;
;;; except when such incorporation is exclusively for your own use ;
;;; or for use by others in your organization in the performance of ;
;;; their normal duties, is prohibited without the prior written ;
;;; consent of Charles Alan Butler, 1403 Duelda Drive, ;
;;; Brandon Florida, 33511 ;
;;; ;
;;; Copying, modification and distribution of this software or any ;
;;; part thereof in any form except as expressly provided herein is ;
;;; prohibited without the prior written consent of Charles Alan ;
;;; Butler, 1403 Duelda Drive, Brandon Florida, 33511 ;
;;; ;
;;;====================================================================;
(defun c:tds (/ ent entbl t:styold t:stynew d:styold d:stynew usercmd
idx x )
(defun set:dim:style (elst)
(setq d:styold (getvar "dimstyle"))
(command "-dimstyle" "restore" (cdr (assoc 3 elst)))
(setq d:stynew (getvar "dimstyle"))
)
(defun set:txt:style (elst)
(setq t:stynew (cdr (assoc 7 elst))
t:styold (getvar "textstyle")
)
(setvar "TextSize" (cdr (assoc 40 elst)))
(setvar "TextStyle" t:stynew)
)
;; ************** Begin Routine ******************
(if (setq ent
(car (entsel "\nSelect Object to make layer current (Enter to None): "))
)
(progn
(setq entbl (entget ent)) ; Get entity definition list
(setq usercmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "undo" "begin")
(cond
;; ============================================================
((= (cdr (assoc 0 entbl)) "LEADER") ; found a leader
(setvar 'clayer (cdr (assoc 8 entbl)))
(set:dim:style entbl); Set Dim Style Current
(cond ; chek to see if text is attched
((and (setq elst (entget(cdr (assoc 340 entbl))))
(wcmatch (cdr (assoc 0 elst)) "*TEXT*"))
(set:txt:style elst); Set TextStyle Current
)
)
); end cond 1

;; ===========================================================
((wcmatch (cdr (assoc 0 entbl)) "*TEXT*") ; gets Rtext as well
(set:txt:style entbl); Set TextStyle Current
(setvar 'clayer (cdr (assoc 8 entbl)))
;; Look for leader to set dim Style Current
(setq idx (length entbl))
(while (> (setq idx (1- idx))-1)
(setq ent (nth idx entbl))
(cond
((and (= (car ent) 330) ; pointer to leader
(setq elst (entget (cdr ent))) ; valid ent ??
(= (cdr (assoc 0 elst)) "LEADER"))
(set:dim:style entbl); Set Dim Style Current
(setq idx 0); 0 = exit loop
); cond
); cond stmt
); while
) ; end cond 2

;; =============================================================
((= (cdr (assoc 0 entbl)) "DIMENSION")
(set:dim:style entbl); Set Dim Style Current
(setvar 'clayer (cdr (assoc 8 entbl)))
) ; end cond 3

;; =============================================================
(t ; catch any other object
(and (cdr (assoc 8 entbl))
(setvar 'clayer (cdr (assoc 8 entbl)))
)
) ; end cond (T)

) ; end Cond stmt
;; *************** Display Changes Made *******************
(prompt (strcat "\n*-* Object selected: " (cdr (assoc 0 entbl))))
(and (cdr (assoc 8 entbl))
(prompt (strcat "\n*-* Layer changed to: " (cdr (assoc 8 entbl)))))
(if d:styold
(prompt (strcat "\n*-* Dimension style changed: "
d:styold " to "
d:stynew "."
)
)
)
(if t:styold
(prompt
(strcat "\n*-* Text style changed: " t:styold " to " t:stynew ".")
)
)
(setq t:stynew nil
t:styold nil
d:stynew nil
d:styold nil
)

(command "undo" "end")
(setvar "CMDECHO" usercmd)
) ; end progn
) ; endif
(princ)
) ;End of Defun
;(prompt "\nText / Dimension Style Changer Loaded, Type TDS to run")
(princ)

(defun c:raa ( / nv oc p1 p2 p3 p4 p5 pl p5a os AScol ASsize )
(if
(and
(setq p1 (getpoint "\n1st point: "))
(setq p2 (getpoint "\n2nd point: " p1))
)
(progn
(setq nv (trans (mapcar '- p2 p1) 1 0 t)
oc (trans '(0.0 0.0 1.0) 1 0 t)
p3 (trans p1 1 nv)
p4 (trans p2 1 nv)
)

;AutoSnap marker color
(setq AScol (LM:OLE->RGB (atoi (getenv "Model AutoSnap Color"))))
(setq AScol (LM:RGB->ACI (car AScol) (cadr AScol) (caddr AScol)))

;AutoSnap marker size
(setq ASsize (* (atoi (getenv "AutoSnapSize")) 0.002))

(princ "\n3rd point: ")
(while (= 5 (car (setq p5 (grread t 13 0))))
(redraw)
(and (setq os (osmode2str)) (setq p5a (osnap (cadr p5) os)))
(if p5a
(progn
(ASvector p5a AScol)
(setq p5a (trans p5a 1 nv))
(mapcar '(lambda ( a b ) (grdraw a b 1 1))
(setq pl
(list p1 p2
(trans (list (car p5a) (cadr p5a) (caddr p4)) nv 1)
(trans (list (car p5a) (cadr p5a) (caddr p3)) nv 1)
)
)
(cons (last pl) pl)
)
)
(progn
(setq p5 (trans (cadr p5) 1 nv))
(mapcar '(lambda ( a b ) (grdraw a b 1 1))
(setq pl
(list p1 p2
(trans (list (car p5) (cadr p5) (caddr p4)) nv 1)
(trans (list (car p5) (cadr p5) (caddr p3)) nv 1)
)
)
(cons (last pl) pl)
)
)
)
)
(if
(and
(listp (cadr p5))
(setq p5 (trans (cadr p5) 1 nv))
)
(progn
(and p5a (setq p5 p5a))
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans p1 1 oc))
(cons 010 (trans p2 1 oc))
(cons 010 (trans (list (car p5) (cadr p5) (caddr p4)) nv oc))
(cons 010 (trans (list (car p5) (cadr p5) (caddr p3)) nv oc))
(cons 210 oc)
)
)
)
)
(redraw)
)
)
(princ)
)

;----------------------------------------------------------
; Return the current osnap mode in the form of a string.
; i.e.: osmode = 37 --> "_end,_cen,_int"
; Gian Paolo Cattaneo - 09/11/2013
;----------------------------------------------------------
(defun osmode2str ( / osm)
(if (> (getvar 'osmode) 0)
(mapcar
'(lambda (a b)
(if (= a (logand a (getvar 'osmode)))
(if osm
(setq osm (strcat osm "," b))
(setq osm b)
)
)
)
'(1 2 4 8 16 32 64 128 256 512)
'("_end" "_mid" "_cen" "_nod" "_qua"
"_int" "_ins" "_per" "_tan" "_nea"
)
)
)
osm
)

;----------------------------------------------------------
;; OLE -> RGB - Lee Mac 2011
;; Args: c - OLE Colour
;----------------------------------------------------------
(defun LM:OLE->RGB ( c )
(list
(lsh (lsh (fix c) 24) -24)
(lsh (lsh (fix c) 16) -24)
(lsh (lsh (fix c) 8) -24)
)
)

;----------------------------------------------------------
;; RGB -> ACI - Lee Mac 2011
;; Args: r,g,b - Red,Green,Blue values
;----------------------------------------------------------
(defun LM:RGB->ACI ( r g b / cObj aci ) (vl-load-com)
(if
(and
(setq cObj
(vla-getInterfaceObject (vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
)
)
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-SetRGB (list cObj r g b))
)
)
)
(setq aci (vla-get-ColorIndex cObj))
)
(if cObj (vlax-release-object cObj))
aci
)

;_____________________credit: ronjonp______________________
(defun ASvector (pt: color / L L- c1 c2 *1 *2 *3 *4 *5 *6
*7 *8 *9 *10 *11 *12)
(setq L (* (* 1.3 ASsize) (getvar 'viewsize))
L- (* 0.9 L)
c1 (polar pt: pi (* L 0.06))
c2 (polar pt: 0.0 (* L 0.06))
*1 (polar c1 0.785 L)
*2 (polar c1 2.356 L-)
*3 (polar c1 3.926 L-)
*4 (polar c1 5.498 L)
*5 (polar c2 0.785 L-)
*6 (polar c2 2.356 L)
*7 (polar c2 3.926 L)
*8 (polar c2 5.498 L-)
*9 (polar pt: 0.785 L)
*10 (polar pt: 2.356 L)
*11 (polar pt: 3.926 L)
*12 (polar pt: 5.498 L)
)
(grvecs (list color *2 *5 *3 *8 *6 *7 *1 *4))
(grvecs (list color *9 *10 *11 *12 *9 *12 *10 *11))
(grvecs (list color *1 *3 *2 *4 *5 *7 *6 *8 *9 *11 *10 *12))
)

;;************

(defun c:cross (/ )

(command "wipeout" "p" "l" "y")

(command "draworder" "l" "" "b")
(c:os)

);defun
(princ)

(defun c:wmk ( )
(c:tds)
(c:raa)
(c:cross)
)
(c:wmk)

Create WipeOUT already drawn by Polyline

18 Sunday Aug 2019

Posted by danglar71 in draw

≈ Leave a comment


;;; Create WipeOUT already drawn by Polyline
;;; Created by Igal Averbuh 2019
;;; Based on Marko Ribar subroutine published here: http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/2-click-solid-hatch/td-p/6055800

(defun c:wh ( / hpn )

(setvar "osmode" 167)

(command "_.pline")
(while (< 0 (getvar 'cmdactive)) (command "\\"))

(command "wipeout" "p" (ssadd (entlast)) "y")

(while (< 0 (getvar 'cmdactive)) (command ""))

(princ)
(command "draworder" "l" "" "b")
)

(c:wh)

Count Length of entities (LINEs, POLYLINEs, LWPOLYLINEs, ARCs, CIRCLEs, ELLIPSEs and SPLINEs) within viewport selected by user with table output

07 Wednesday Aug 2019

Posted by danglar71 in Counting

≈ 2 Comments


;;; Count Length of entities (LINEs,POLYLINEs,LWPOLYLINEs,ARCs,CIRCLEs,ELLIPSEs and SPLINEs) within viewport selected by user with table output
;;; Based on Jimmy Bergmark, Lee Mac, CAB, Kent Cooper, DannyNL, Marco Antonio Jacinto Perez and BeekeeCZ subroutines
;;; Close Solution for blocks counting inside closed polyline saved from:
;;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-request-block-count-inside-a-closed-polyline/td-p/7665364
;;; Final routine created by Igal Averbuh 2019 (combined from existing routines with some modifications)

;;; Rotates tables around their insertion points
;;; Created by BeekeeCZ
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-rotate-acad-table/td-p/8771700

(defun c:ROT ( / ss i ent dir pnt eng ucs)

(if (setq ss (ssget "L" '((0 . "ACAD_TABLE"))))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq dir (getpropertyvalue ent "Direction"))
(setq pnt (cdr (assoc 10 (entget ent))))
(setq ang (angle '(0 0 0) dir))
(setq ucs (angle '(0 0 0) (getvar 'UCSXDIR)))
(command "_.rotate" ent "" "_non" (trans pnt 0 1) "_R" (angtos ang (getvar 'AUNITS) 8) (angtos ucs (getvar 'AUNITS) 8))))
(princ)
)

;; ScaleAboutCenters.lsp [command name: SAC]
;; To Scale multiple objects, each About its own Center, by the same User-specified
;; scale factor.
;; Uses the middle of each object's bounding box as the base point for scaling, to
;; keep objects centered at approximately the same position in the drawing.
;; [For Mtext, that will be based on the defined Mtext box width, not the extents
;; of the content; for a Block or Text, the center of its extents in the drawing, not
;; its insertion point; for an Arc, the center of its extents, not its geometric center;
;; some entity types' (e.g. Spline's) bounding box can sometimes reach beyond
;; its extents and affect results slightly.]
;; Rejects selection of objects on locked Layers, or without a "center" [Rays, Xlines].
;; Stores scale factor; offers as default on subsequent use in same editing session.
;; Kent Cooper, 6 May 2014

(defun C:SAC (/ *error* cmde ss inc ent)
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); end if
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); end defun - *error*
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(setq *SACscl
(cond
( (getreal
(strcat
"\nEnter Scale Factor for blocks couning table : "
); strcat
); getreal
); User-input condition
(*SACscl); Enter on subsequent use [prior value]
(1); Enter on first use
); cond & *SACscl
ss (ssget "L" '((-4 . "")))
;; not objects on Locked Layers or without finite extents
); setq
(repeat (setq inc (sslength ss))
(setq ent (ssname ss (setq inc (1- inc))))
(vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
(command
".scale" ent "" "_none"
(mapcar '/ ; midpoint of bounding box
(mapcar '+ (vlax-safearray->list minpt) (vlax-safearray->list maxpt))
'(2 2 2)
); mapcar
*SACscl
); command
); repeat
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); defun
(vl-load-com)

;;; vp-outline.lsp
;;;
;;; Creates a polyline in modelspace that
;;; has the outline of the selected viewport.
;;; Supports clipped viewports. polyline is supported
;;; ellipse, spline, region and circle not supported at this point
;;; If vp-outline is called when in mspace it detects
;;; the active viewport.
;;;
;;; c:vp-outline
;;;
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2013 JTB World, All Rights Reserved
;;; Website: http://www.jtbworld.com
;;; E-mail: info@jtbworld.com
;;;
;;; 2000-04-10
;;; 2003-11-19 Added support for drawing the outline in other ucs/view than world/current
;;;
;;; 2006-04-06 Added support for twisted views Tom Beauford
;;; 2013-06-08 Added support for circular viewports
;;;
;;; Should work on AutoCAD 2000 and newer
(vl-load-com)

(defun dxf (n ed) (cdr (assoc n ed)))

(defun ax:List->VariantArray (lst)
(vlax-Make-Variant
(vlax-SafeArray-Fill
(vlax-Make-SafeArray
vlax-vbDouble
(cons 0 (- (length lst) 1))
)
lst
)
)
)

(defun c:vp (/ ad ss ent pl plist xy n vpbl vpur msbl msur ven vpno ok
circ)
(setq ad (vla-get-activedocument (vlax-get-acad-object)))
(if (= (getvar "tilemode") 0)
(progn
(if (= (getvar "cvport") 1)
(progn
(if (setq ss (ssget ":E:S" '((0 . "VIEWPORT"))))
(progn (setq ent (ssname ss 0))
(setq vpno (dxf 69 (entget ent)))
(vla-Display (vlax-ename->vla-object ent) :vlax-true)
(vla-put-mspace ad :vlax-true) ; equal (command "._mspace")
; this to ensure trans later is working on correct viewport
(setvar "cvport" vpno)
; (vla-put-mspace ad :vlax-false) ; equal (command "._pspace")
(setq ok T)
(setq ss nil)
)
)
)
(setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))
ok T
)
)
(if ok
(progn (setq circle nil)
(setq ven (vlax-ename->vla-object ent))
(if (/= 1 (logand 1 (dxf 90 (entget ent)))) ; detect perspective
(progn (if (= (vla-get-clipped ven) :vlax-false)
(progn ; not clipped
(vla-getboundingbox ven 'vpbl 'vpur)
(setq vpbl (trans (vlax-safearray->list vpbl) 3 2)
msbl (trans vpbl 2 1)
msbl (trans msbl 1 0)
vpur (trans (vlax-safearray->list vpur) 3 2)
msur (trans vpur 2 1)
msur (trans msur 1 0)
vpbr (list (car vpur) (cadr vpbl) 0)
msbr (trans vpbr 2 1)
msbr (trans msbr 1 0)
vpul (list (car vpbl) (cadr vpur) 0)
msul (trans vpul 2 1)
msul (trans msul 1 0)
plist (list (car msbl)
(cadr msbl)
(car msbr)
(cadr msbr)
(car msur)
(cadr msur)
(car msul)
(cadr msul)
)
)
)
(progn ; clipped
(setq pl (entget (dxf 340 (entget ent))))
(if (= (dxf 0 pl) "CIRCLE")
(setq circle T)
(progn (setq plist (vla-get-coordinates
(vlax-ename->vla-object (dxf -1 pl))
)
plist (vlax-safearray->list (vlax-variant-value plist))
n 0
pl nil
)
(repeat (/ (length plist) 2)
(setq xy (trans (list (nth n plist) (nth (1+ n) plist)) 3 2)
xy (trans xy 2 1)
xy (trans xy 1 0)
pl (cons (car xy) pl)
pl (cons (cadr xy) pl)
n (+ n 2)
)
)
(setq plist (reverse pl))
)
)
)
)
(if circle
(vla-AddCircle
(vla-get-ModelSpace ad)
(ax:List->VariantArray
(trans (trans (trans (dxf 10 pl) 1 0) 2 1) 3 2)
)
(/ (dxf 40 pl) (caddr (trans '(0 0 1) 2 3)))
)
(vla-Put-Closed
(vla-AddLightWeightPolyline
(vla-get-ModelSpace ad)
(ax:List->VariantArray plist)
)
:vlax-True
)
)
)
)
)
)
)
)
(if ss
(vla-put-mspace ad :vlax-false)
) ; equal (command "._pspace"))
(princ)
)

;;;=======================[ BreakObjects.lsp ]==============================
;;; Author: Copyright© 2006-2019 Charles Alan Butler
;;; Contact @ http://www.TheSwamp.org
;;; http://www.theswamp.org/index.php?topic=10370.0
;;; Version: 2.3 June 6,2019
;;; Purpose: Break All selected objects
;;; permitted objects are lines, lwplines, plines, splines,
;;; ellipse, circles & arcs
;;;
;;; Function c:MyBreak - DCL for selecting the routines
;;; Function c:BreakAll - Break all objects selected with each other
;;; Function c:BreakwObject - Break many objects with a single object
;;; Function c:BreakObject - Break a single object with other objects
;;; Function c:BreakWith - Break selected objects with other selected objects
;;; Function c:BreakTouching - Break objects touching selected objects
;;; Function c:BreakSelected - Break selected objects with any objects that touch it
;;; Function c:BreakRemove - Break selected object with any objects that touch it & remove
;;; every other new segment, start with selected object
;;; Revision 1.8 Added Option for Break Gap greater than zero
;;; NEW r1.9 c:BreakWlayer - Break objects with objects on a layer
;;; NEW r1.9 c:BreakWithTouching - Break touching objects with selected objects
;;; Revision 2.0 Fixed a bug when point to break is at the end of object
;;; Revision 2.1 Fixed another bug when point to break is at the end of object
;;; Revision 2.2 Fixed another bug when closed objects are to be broken
;;; Revision 2.3 test for BricsCAD 06.06.2019
;;;
;;; Function break_with - main break function called by all others and
;;; returns a list of new enames, see c:BreakAll
;;; for an example of using the return list
;;;
;;; Requirements: objects must have the same z-value
;;; Restrictions: Does not Break objects on locked layers
;;; Returns: none
;;;
;;;=====================================================================
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED ;
;;; WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR ;
;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED. ;
;;; ;
;;; You are hereby granted permission to use, copy and modify this ;
;;; software without charge, provided you do so exclusively for ;
;;; your own use or for use by others in your organization in the ;
;;; performance of their normal duties, and provided further that ;
;;; the above copyright notice appears in all copies and both that ;
;;; copyright notice and the limited warranty and restricted rights ;
;;; notice below appear in all supporting documentation. ;
;;;=====================================================================

(setq Brics (wcmatch (getvar 'acadver) "*BricsCAD*" )) ; test for BricsCAD 06.06.19

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(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) ( 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 ( #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
(( 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
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D O F M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;======================
;; Redraw ss with mode
;;======================
(defun ssredraw (ss mode / i num)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)

;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (sscros / ss lst lstb lstc objl)
(and
(setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
objl (mapcar 'vlax-ename->vla-object lstb)
)
(setq
ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))))
)
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(mapcar
'(lambda (y)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith y x acextendnone)
))))))
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
) objl)
) lst)
)
lstc
)

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D M A I N F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;===============================================
;; Break all objects selected with each other
;;===============================================
(defun c:BreakAll (/ cmd ss NewEnts AllEnts tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(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)
(command "_.undo" "_end")
(princ)
)

;;===========================================
;; Break a single object with other objects
;;===========================================
(defun c:BreakObject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nSelect single object to break: ")
(if (and (setq ss1 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 4)))
(Break_with ss1 ss2 nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================
;; Break many objects with a single object
;;==========================================
(defun c:BreakWobject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select single object to break with: ***"))
(setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================
;; Break objects with objects on a layer
;;==========================================
;; New 08/01/2008
(defun c:BreakWlayer (/ cmd ss1 ss2 tmp lay)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\n*** Select single object for break layer: ***")

(if (and (setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq lay (assoc 8 (entget (ssname ss2 0))))
(setq ss2 (ssget "_X" (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
lay (cons 410 (getvar "ctab")))))
(not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss1 (ssget (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 8 (strcat "~" (cdr lay))))))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;======================================================
;; Break selected objects with other selected objects
;;======================================================
(defun c:BreakWith (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;=============================================
;; Break objects touching selected objects
;;=============================================

(defun c:BT (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 1)) ; default
(initget 4) ; no negative numbers

;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(if (and (not (prompt ""))
(setq ss2 (ssget "L" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;=================================================
;; Break touching objects with selected objects
;;=================================================
;; New 08/01/2008
(defun c:BreakWithTouching (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(prompt "\nSelect object(s) to break with & press enter: ")
(if (and (setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq tlst (gettouching ss2))
)
(progn
(setq tlst (vl-remove-if '(lambda (x)(ssmemb x ss2)) tlst)) ; remove if in picked ss
(mapcar '(lambda (x) (ssadd x ss1)) tlst) ; convert to a selection set
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================================
;; Break selected objects with any objects that touch it
;;==========================================================

(defun c:BreakSelected (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil Bgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================================
;; Break selected object with any objects that touch it and remove every
;; other segment of the broken object, start with selected object
;;==========================================================

(defun c:BreakRemove (/ cmd ss1 ss2 tmp entlst ename ent en e dist)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(setq Bgap 0
tmp 1)
;; get object to break
(prompt "\nBreak selected object with any objects that touch it.")
(if (and (not (prompt "\nSelect object to break with touching & press enter: "))
(setq ss2 (ssget "_+.:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (setq touch (gettouching ss2)))
)
(setq entlst (break_with ss2 ss1 nil Bgap)) ; ss2break ss1breakwith (flag nil = not to break with self)
)
(if (not (member (setq ename (ssname ss2 0)) entlst))(setq entlst (append entlst (list ename))))
(setq pt (cadr(cadddr(car (ssnamex ss2 0))))) ; pick point for ss2
(foreach ent entlst ; find the new object that is at the picked spot
(cond
((null dist)
(if (setq p (vlax-curve-getclosestpointto ent pt))
(setq dist (distance pt p)
en ent)))
((setq p (vlax-curve-getclosestpointto ent pt))
(if ( (setq lp (1- lp)) 0)
(setq ln (read-line fn)) ; get a line from file
(if (vl-string-search rvflag ln)
(setq lp 0)
)
)
(close fn) ; close the open file handle
(if (= lp -1)
nil ; no new dcl needed
t ; flag to create new file
)
)
t ; flag to create new file
)
)
(if (null(wcmatch (strcase fname) "*`.DCL"))
(setq fname (strcat fname ".DCL"))
)
(if (dcl-rev-check fname)
;; create dcl file in same directory as ACAD.PAT
(progn
(setq patfn (if Brics "default.pat" "ACAD.PAT")
acadfn (findfile patfn)
;; kdub revised 060619 ;; fn (strcat (substr acadfn 1 (- (strlen acadfn) 8))fname)
fn (strcat (vl-filename-directory acadfn) "\\" fname)
fn (open fn "w")
)

(foreach x (list
"// WARNING file will be recreated if you change the next line"
rvflag
"//BreakAll.DCL"
"BreakDCL : dialog { label = \"[ Break All or Some by CAB v2.3 ]\";"
" : text { label = \"--==--\"; "
" key = \"tm\"; alignment = centered; fixed_width = true;}"
" spacer_1;"
" : button { key = \"b1\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break all objects selected with each other\";} "
" : button { key = \"b2\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break selected objects with other selected objects\";}"
" : button { key = \"b3\"; mnemonic = \"T\"; alignment = centered;"
" label = \" Break selected objects with any objects that touch it\";}"
" spacer_1;"
" : row { spacer_0;"
" : edit_box {key = \"gap\" ; width = 8; mnemonic = \"G\"; label = \"Gap\"; fixed_width = true;}"
" : button { label = \"Help\"; key = \"help\"; mnemonic = \"H\"; fixed_width = true;} "
" cancel_button;"
" spacer_0;"
" }"
"}"
) ; endlist
(princ x fn)
(write-line "" fn)
) ; end foreach
(close fn)
(setq acadfn nil)
(alert (strcat "\nDCL file created, please restart the routine"
"\n again if an error occures."))
t ; return True, file created
)
t ; return True, file found
)
) ; end defun

;;==============================
;; BreakAll Dialog Routine
;;==============================
(defun c:MyBreak(/ dclfile dcl# RunDCL BreakHelp cmd txt2num)
;; return number or nil
(defun txt2num (txt / num)
(if txt
(or (setq num (distof txt 5))
(setq num (distof txt 2))
(setq num (distof txt 1))
(setq num (distof txt 4))
(setq num (distof txt 3))
)
)
(if (numberp num)
num
)
)
(defun mydonedialog (flag)
(setq DCLgap (txt2num (get_tile "gap")))
(done_dialog flag)
)
(defun RunDCL (/ action)
(or DCLgap (setq DCLgap 0)) ; error trap value
(action_tile "b1" "(mydonedialog 1)")
(action_tile "b2" "(mydonedialog 2)")
(action_tile "b3" "(mydonedialog 3)")
(action_tile "gap" "(setq DCLgap (txt2num value$))")
(set_tile "gap" (rtos DCLgap))
(action_tile "help" "(BreakHelp)")
(action_tile "cancel" "(done_dialog 0)")
(setq action (start_dialog))
(or DCLgap (setq DCLgap 0)) ; error trap value
(setq DCLgap (max DCLgap 0)) ; nu negative numbers

(cond
((= action 1) ; BreakAll
(command "_.undo" "_begin")
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil DCLgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(command "_.undo" "_end")
(princ)
)

((= action 2) ; BreakWith
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil DCLgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

)
((= action 3) ; BreakSelected
(setq ss1 (ssadd))
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil DCLgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)
)
)
)
(defun BreakHelp ()
(alert
(strcat
"BreakAll.lsp (c) 2007-2019 Charles Alan Butler\n\n"
"This LISP routine will break objects based on the routine you select.\n"
"It will not break objects on locked layers and objects must have the same z-value.\n"
"Object types are limited to LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE\n"
"BreakAll - Break all objects selected with each other\n"
"BreakwObject - Break many objects with a single object\n"
"BreakObject - Break a single object with many objects \n"
"BreakWith - Break selected objects with other selected objects\n"
"BreakTouching - Break objects touching selected objects\n"
"BreakSelected - Break selected objects with any objects that touch it\n"
" The Gap distance is the total opening created.\n"
"You may run each routine by entering the function name at the command line.\n"
"For updates & comments contact Charles Alan Butler AKA CAB at TheSwamp.org.\n")
)
)

;;================================================================
;; Start of Routine
;;================================================================
(vl-load-com)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq dclfile "BreakAll.dcl")
(cond
((not (create_Breakdcl dclfile))
(prompt (strcat "\nCannot create " dclfile "."))
)
(( (setq n (1- n)) -1)
(if (and
(setq ss1 (ssget WC (mapcar 'cdr (vl-remove-if-not '(lambda (item) (= (car item) 10)) (entget (ssname pSS n))))))
(setq m (sslength ss1)) ;number of objects inside of polyline
)
(while (> (setq m (1- m)) -1)
(setq en (ssname ss1 m)) ;en = list of entity names inside of polyline
(ssadd en ss)

)
)

(setq ss1 nil)
(gc)
)
)
(if (> (sslength ss) 1)
(sssetfirst nil ss)
)
)

;Count selected objects length and area by layer
;Stefan M. 22.09.2016
(defun C:LAY ( / *error* acdoc ss p i e a d l s h dz) (vl-load-com)
(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
dz (getvar 'dimzin))
(vla-startundomark acdoc)
(setvar 'dimzin 1)

(defun *error* (msg)
(and
msg
(not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(setvar 'dimzin dz)
(if
(= 8 (logand (getvar 'undoctl) 8))
(vla-endundomark acdoc)
)
(princ)
)

(if
(and
(setq ss (ssget "P" '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE,HATCH"))))
(setq p (getpoint "\nTable scale depend on annotation scale.\nSpecify table insert point: "))
)
(progn
(repeat
(setq i (sslength ss))
(setq e (vlax-ename->vla-object (ssname ss (setq i (1- i))))
a (vla-get-layer e)
)
(if
(setq h (eq (vla-get-objectname e) "AcDbHatch"))
(setq s (vla-get-area e))
(setq d (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
)
(if
(setq o (assoc a l))
(if h
(setq l (subst (list a (cadr o) (+ (caddr o) s)) o l))
(setq l (subst (list a (+ (cadr o) d) (caddr o)) o l))
)
(if h
(setq l (cons (list a 0.0 s) l))
(setq l (cons (list a d 0.0) l))
)
)
)
(setq l (vl-sort l '(lambda (a b) (< (car a) (car b)))))
(insert_table l p)
)
)
(*error* nil)
(princ)
)

(defun insert_table (lst pct / tab row col ht i n space )
(setq space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
ht (/ 2.5 (cond ((getvar 'cannoscalevalue)) (1.0)))
pct (trans pct 1 0)
n (trans '(1 0 0) 1 0 T)
tab (setq tab (vla-addtable space (vlax-3d-point pct) (+ 2 (length lst)) (length (car lst)) (* 2.5 ht) ht))
)
(vlax-put tab 'direction n)

(mapcar
(function
(lambda (rowType)
(vla-SetTextStyle tab rowType (getvar 'textstyle))
(vla-SetTextHeight tab rowType ht)
)
)
'(2 4 1)
)

(vla-put-HorzCellMargin tab (* 0.14 ht))
(vla-put-VertCellMargin tab (* 0.14 ht))

(setq lst (cons '("Layer" "Length") lst))

(setq i 0)
(foreach col (apply 'mapcar (cons 'list lst))
(vla-SetColumnWidth tab i
(apply
'max
(mapcar
'(lambda (x)
((lambda (txb) (+ (abs (- (caadr txb) (caar txb))) (* 2.0 ht)))
(textbox
(list
(cons 1
(cond
((eq (type x) 'STR) x)
((eq (type x) 'INT) (itoa x))
((eq (type x) 'REAL) (rtos x))
)
)
(cons 7 (getvar 'textstyle))
(cons 40 ht))
)
)
)
col
)
)
)
(setq i (1+ i))
)

(setq lst (cons '("TITLE") lst))

(setq row 0)
(foreach r lst
(setq col 0)
(foreach c r
(if
(not (eq c 0))
(progn
(vla-SetText tab row col c)
(vla-SetCellDataType
tab row col
(cdr (assoc (type c) '((STR . 4) (REAL . 2) (INT . 1))))
acUnitless
)
(vla-setCellAlignment tab row col acMiddleCenter)
)
)
(setq col (1+ col))
)
(vla-SetRowHeight tab row (* 1.6 ht))
(setq row (1+ row))
)
)

(defun c:igal () ;; Create text style arial.ttf
(command "-style" "igal" "arial.ttf" "" "" "0" "" "" "")
)

;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

(defun c:vlc()
(c:igal)
(command "_.-LAYER" "_T" "0-LENGTH-COUNTING" "_U" "0-LENGTH-COUNTING" "_M" "0-LENGTH-COUNTING" "_C" 1 "0-LENGTH-COUNTING" "")
(princ "\n Select ViewPort for Counting Area Definition...")
(c:vp) ; create vport outline
(setvar "tilemode" 1)
(c:bt) ; cut objects by vport outline
(setvar "tilemode" 0)
(command "._pspace")
(princ "\n Select ViewPort for LENGTH Counting Inside Defined Vport...")
(c:vp) ; create vport outline
(c:sip) ; select objects inside vport outline polyline
(c:lay) ; count length of entities inside selected vport
(setvar "osmode" 0)

(command "._chspace" "L" "" "")
(c:rot)
(c:sac)
(setvar "osmode" 167)
)

Recent Posts

  • Это наша плата за трусость
  • Set the Default Application to open DWG Files
  • Draw “Heat Grid” (Lee Mac)
  • PROGRAM FOR SPRINKLER DISTRIBUTION
  • How to remove Frames around blocks

Recent Comments

Wilmer Lacayo on Draw Centroid (center of gravi…
Jun on Convert Polylines to Leaders i…
Adel on HVAC Draw Branch Duct
danglar71 on Draw “Heat Grid” (…
IOAN VLAD on Draw “Heat Grid” (…

Archives

  • January 2021
  • March 2020
  • February 2020
  • January 2020
  • October 2019
  • September 2019
  • August 2019
  • July 2019
  • June 2019
  • May 2019
  • April 2019
  • February 2019
  • January 2019
  • December 2018
  • November 2018
  • October 2018
  • September 2018
  • August 2018
  • July 2018
  • June 2018
  • April 2018
  • March 2018
  • February 2018
  • January 2018
  • December 2017
  • November 2017
  • August 2017
  • July 2017
  • June 2017
  • May 2017
  • April 2017
  • March 2017
  • February 2017
  • January 2017
  • December 2016
  • November 2016
  • October 2016
  • September 2016
  • August 2016
  • July 2016
  • June 2016
  • May 2016
  • April 2016
  • March 2016
  • February 2016
  • January 2016
  • December 2015
  • November 2015
  • October 2015
  • September 2015
  • August 2015
  • July 2015
  • June 2015
  • May 2015
  • April 2015
  • March 2015
  • February 2015
  • January 2015
  • December 2014
  • November 2014

Categories

  • 3D
  • Annonymous Blocks
  • Attribute
  • Batch
  • Blocks
  • Books
  • Common
  • Coordinates
  • Counting
  • dimmensions
  • draw
  • Export
  • Fractal
  • Hatch
  • HVAC
  • Images
  • Import
  • Info
  • Isometric
  • Layers
  • Layouts
  • Lisp Collection 2014
  • Mline
  • Pdf
  • Pipes
  • plot
  • Points
  • Protect
  • Text
  • Tips (English)
  • Tips (Russian)
  • ucs
  • Utilites
  • view
  • Vport
  • Xref

Recent Posts

  • Это наша плата за трусость
  • Set the Default Application to open DWG Files
  • Draw “Heat Grid” (Lee Mac)
  • PROGRAM FOR SPRINKLER DISTRIBUTION
  • How to remove Frames around blocks

Recent Comments

Wilmer Lacayo on Draw Centroid (center of gravi…
Jun on Convert Polylines to Leaders i…
Adel on HVAC Draw Branch Duct
danglar71 on Draw “Heat Grid” (…
IOAN VLAD on Draw “Heat Grid” (…

Archives

  • January 2021
  • March 2020
  • February 2020
  • January 2020
  • October 2019
  • September 2019
  • August 2019
  • July 2019
  • June 2019
  • May 2019
  • April 2019
  • February 2019
  • January 2019
  • December 2018
  • November 2018
  • October 2018
  • September 2018
  • August 2018
  • July 2018
  • June 2018
  • April 2018
  • March 2018
  • February 2018
  • January 2018
  • December 2017
  • November 2017
  • August 2017
  • July 2017
  • June 2017
  • May 2017
  • April 2017
  • March 2017
  • February 2017
  • January 2017
  • December 2016
  • November 2016
  • October 2016
  • September 2016
  • August 2016
  • July 2016
  • June 2016
  • May 2016
  • April 2016
  • March 2016
  • February 2016
  • January 2016
  • December 2015
  • November 2015
  • October 2015
  • September 2015
  • August 2015
  • July 2015
  • June 2015
  • May 2015
  • April 2015
  • March 2015
  • February 2015
  • January 2015
  • December 2014
  • November 2014

Categories

  • 3D
  • Annonymous Blocks
  • Attribute
  • Batch
  • Blocks
  • Books
  • Common
  • Coordinates
  • Counting
  • dimmensions
  • draw
  • Export
  • Fractal
  • Hatch
  • HVAC
  • Images
  • Import
  • Info
  • Isometric
  • Layers
  • Layouts
  • Lisp Collection 2014
  • Mline
  • Pdf
  • Pipes
  • plot
  • Points
  • Protect
  • Text
  • Tips (English)
  • Tips (Russian)
  • ucs
  • Utilites
  • view
  • Vport
  • Xref

Blog at WordPress.com.

Privacy & Cookies: This site uses cookies. By continuing to use this website, you agree to their use.
To find out more, including how to control cookies, see here: Cookie Policy