;;; Draw filled rotated envelope
;;; Combined by Igal Averbuh 2018
;;; Based on Lee Mak routines (draw rotated rectangle)
;;; and Lions60 routine (draw cross lines)
;;; Saved from: http://forums.augi.com/showthread.php?94906-LISP-to-draw-cross
;;;====================================================================;
;;; 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:cross2 (/ pnt1 pnt2 pnt3 pnt4 lst e len n e1 ss)
;(setq ew (list (entlast)))
;(command "_.RECTANG" pause "_R" "_P" "@" (getpoint (getvar 'lastpoint)) pause)
(setq ss (ssadd (entlast)))
(setq e (entget (entlast)))
;get the entity list
(setq len (length e))
;get the length of the list
(setq n 0)
;set counter to zero
(setq lst nil)
(repeat len
;repeat for the length of the entity list
(setq e1 (car (nth n e)))
;get each item in the entity list
;and strip the entity code number
(if (= e1 10)
;check for code 10 (vertex)
(progn
;if it's group 10 do the following
(terpri)
;new line
(setq lst (if lst (append lst (list(cdr (nth n e))))(list(cdr (nth n e)))))
);progn
);if
(setq n (1+ n))
;increment the counter
);repeat
(mapcar 'set '(pnt1 pnt2 pnt3 pnt4) lst)
(setq pnt1 (strcat(rtos(car pnt1))"," (rtos(cadr pnt1))))
(setq pnt2 (strcat(rtos(car pnt2)) ","(rtos(cadr pnt2))))
(setq pnt3 (strcat(rtos(car pnt3)) ","(rtos(cadr pnt3))))
(setq pnt4 (strcat(rtos(car pnt4)) ","(rtos(cadr pnt4))))
(command "line" pnt1 pnt3 "")
(ssadd (entlast) ss)
;(command "line" pnt2 pnt4 "")
(command "solid" pnt1 pnt2 pnt3 "" "")
(ssadd (entlast) ss)
(command "_.COPYBASE" pnt1 ss "")
(command "_.PASTEBLOCK" pnt1)
(command "_.ERASE" ss "")
(princ)
);defun
(defun c:ef ( )
(c:tds)
(c:raa)
(c:cross2)
)
