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


;;; 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)


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


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


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


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

What prefixes are available for AutoCAD commands? 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.


;;-----------------------=={ 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


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


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


;;; 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)
)