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

LispBox

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

Monthly Archives: October 2018

Add curved “V” connection to polyline (example: for lighting design purposes)

31 Wednesday Oct 2018

Posted by danglar71 in draw, Utilites

≈ Leave a comment


;Add curved "V" connection to polyline
;Created by Stefan M. 30.10.2018
;Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/not-trivial-problem-or-how-to-draw-it/td-p/8368190

(defun c:ac ( / *error* add_vertex e p1 p2 d a b1 b2 u q g)
;;; (setq *error* (err))
(defun add_vertex (e a p)
(vla-addvertex e a
(vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble '(0 . 1))
(list (car p) (cadr p))
)
)
)
(if
(and
(setq e (ssget "_+.:S:L" '((0 . "LWPOLYLINE"))))
(setq e (vlax-ename->vla-object (ssname e 0)))
)
(while
(setq p1 (getpoint "\nSpecify point to add vertex: "))
(setq p1 (trans p1 1 0)
p2 (vlax-curve-getclosestpointto e p1)
a (fix (vlax-curve-getparamatpoint e p2))
)
(if
(and
(equal (vla-getbulge e a) 0.0 1e-8)
(setq d (distance p1 p2)
b1 (vlax-curve-getpointatparam e a)
b2 (vlax-curve-getpointatparam e (1+ a))
)
(and
(> d 0)
(> (distance b1 p2) d)
(> (distance b2 p2) d)
)
(setq u (angle b2 b1)
q (<
(* (- (cadr p1) (cadr b1)) (cos u))
(* (- (car p1) (car b1)) (sin u))
)
g (* (if q 1 -1) (1- (sqrt 2)))
)
)
(progn
(add_vertex e (+ 1 a) (polar p2 (angle p2 b1) d))
(add_vertex e (+ 2 a) p1)
(add_vertex e (+ 3 a) (polar p2 (angle p2 b2) d))
(vla-setbulge e (+ 1 a) g)
(vla-setbulge e (+ 2 a) g)
)
)
)
)
;;; (*error* nil)
(princ)
)
(c:ac)

Draw Rotated Rectangle (BeekeeCZ Solution)

30 Tuesday Oct 2018

Posted by danglar71 in draw

≈ Leave a comment


;;; Draw Rotated Rectangle (BeekeeCZ Solution)
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-save-it-as-a-block/td-p/8365570

(defun c:raa()
(command "_.RECTANG" pause "_R" "_P" "@" (getpoint (getvar 'lastpoint)) pause)
(princ)
)

Copy entities and paste it as block with user selected insertion point at once

30 Tuesday Oct 2018

Posted by danglar71 in Blocks, Utilites

≈ Leave a comment


;;; Copy entities and paste it as block with user selected insertion point at once
;;; Created by Igal Averbuh 2018

(defun c:cpb (/ ss)
(command "ucs" "w")
(setvar "cmdecho" 0)
(setvar "osmode" 167)
(command "-layer" "u" "*" "")
(princ "\nSelect objects to copy and paste as block:")
(setq ss (ssget))
(princ "\nSelect insertion point of block:")
(setq pnt1 (getpoint))
(command "_.COPYBASE" pnt1 ss "")
(command "_.PASTEBLOCK" pnt1)
(command "_.ERASE" ss "")

(command "ucs" "previous")
(setvar "ucsicon" 1)
(setvar "cmdecho" 1)
(princ)

)
;(c:cpb)

Draw rotated envelope as block

30 Tuesday Oct 2018

Posted by danglar71 in draw

≈ Leave a comment


;;; Draw 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
;;; with improvements of BeekeeCZ (create envelope as a block)
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-save-it-as-a-block/td-p/8365570

(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 (/ pnt1 pnt2 pnt3 pnt4 lst e len n e1 ss)

;(setq ew (list (entlast)))

(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 "")

(ssadd (entlast) ss)

(command "_.COPYBASE" pnt1 ss "")
(command "_.PASTEBLOCK" pnt1)
(command "_.ERASE" ss "")

(princ)
);defun

(defun c:ev ( )
(c:raa)
(c:cross)
)
(c:ev)

Create Complete Xref Report (xref tree, xref name,saved path,xref insertion point, layout, scale, rotation angle, layer and xref amount)

25 Thursday Oct 2018

Posted by danglar71 in Export

≈ Leave a comment


;;; Create Complete Xref Report (xref tree, xref name,saved path,xref insertion point, layout,scale,rotation angle,layer and amount)
;;; about all xref's in a drawing
;;; Created by many authors. Published with great respect to them...
;;; Combined and slightly modified by igal Averbuh 2018

; xreftree.lsp prints xref treeview to file
(princ"\nLoading Command Line XrefTree...")
(defun c:XrefTree ( / GetXrefNesting PrintNestedList outputfile fopen)

(defun *error*(msg)(if fopen (close fopen)))

(defun GetXrefNesting (/ GetXrefInfo tempData tempEnt XrefList NonNestedXrefList NestedXrefList )

(defun GetXrefInfo ( ent / NestList )
(foreach i (member '(102 . "{BLKREFS") (entget ent))
(if (equal (car i) 332)
(progn
(setq NestedList (cons (cdr i) NestedList))
(setq NestList
(cons
(cons
(cdr i)
(GetXrefInfo (cdr i))
)
NestList
)
)
)
)
)
NestList
)
;-------------------------------------

(while (setq tempData (tblnext "block" (not tempData)))
(if (equal (logand (cdr (assoc 70 tempData)) 4) 4)
(progn
(setq tempEnt (tblobjname "block" (cdr (assoc 2 tempData))))
(setq tempEnt (cdr (assoc 330 (entget tempEnt))))
(setq XrefList
(cons
(cons
tempEnt
(GetXrefInfo tempEnt)
)
XrefList
)
)
)
)
)
(foreach i XrefList
(if (not (member (car i) NestedList))
(setq NonNestedXrefList (cons i NonNestedXrefList))
)
)
NonNestedXrefList
)
;------------------------------------------------
(defun PrintNestedList ( lst spc )
(foreach i
(vl-sort lst (function (lambda ( a b ) ( " (cdr(assoc 1 (tblsearch"BLOCK"(cdr (assoc 2 (entget (car i)))))))) fopen)
; (prompt (strcat "\n" spc " Nested xref: " (cdr (assoc 2 (entget (car i))))))
(PrintNestedList (cdr i) (strcat " " spc))
)
)
;-----------------------------------------------------

(setq outputfile (open (setq Path (strcat (getvar 'DwgPrefix) (vl-filename-base (getvar 'DwgName)) "_Xref-Tree.txt")) "w"))

(setq outputfile
(strcat
(getvar 'dwgprefix)
(vl-filename-base (getvar 'dwgname))
"_Xref-Tree.txt"
)
)
(setq fopen (open outputfile "w"))
(write-line (strcat "Drawing Name --> " (getvar 'dwgprefix) (vl-filename-base (getvar 'dwgname)) ".dwg") fopen)
(foreach i
(vl-sort (GetXrefNesting) (function (lambda ( a b ) ( " (cdr(assoc 1 (tblsearch"BLOCK"(cdr(assoc 2 (entget (car i)))))))) fopen)
; (prompt (strcat "\n Main xref: " (cdr (assoc 2 (entget (car i))))))
(PrintNestedList (cdr i) " |-")
)
(close fopen)
(startapp "notepad.exe" outputfile)
(princ)
) ; defun
;(princ"\n...Loaded. To Start Command type: XrefTree.")(princ)

(defun c:PXI ( / GetXrefs XrList Opened Data Path )

(defun GetXrefs (/ tempData tempEnt XrefList)

(while (setq tempData (tblnext "block" (not tempData)))
(if (equal (logand (cdr (assoc 70 tempData)) 4) 4)
(progn
(setq tempEnt (tblobjname "block" (cdr (assoc 2 tempData))))
(setq tempData (entget (cdr (assoc 330 (entget tempEnt)))))
(setq XrefList
(cons
(cons
tempEnt
(
(lambda ( x / InsList NestList )
(foreach i x
(cond
((equal (car i) 331)
(setq InsList (cons (cdr i) InsList))
)
((equal (car i) 332)
(setq NestList (cons (cdr i) NestList))
)
)
)
(list InsList NestList)
)
(member '(102 . "{BLKREFS") tempData)
)
)
XrefList
)
)
)
)
)
XrefList
)
;-----------------------------------------------------
(if (setq XrList (GetXrefs))
(progn
(setq Opened (open (setq Path (strcat (getvar 'DwgPrefix) (vl-filename-base (getvar 'DwgName)) "_Xref-Report.txt")) "w"))
(foreach i XrList
(setq Data (entget (car i)))
(write-line (strcat "Xref name: " (cdr (assoc 2 Data))) Opened)
(write-line (strcat "\tSaved path: " (cdr (assoc 1 Data))) Opened)
(write-line (strcat "\tFound at path: " (findfile (cdr (assoc 1 Data)))) Opened)
(write-line "\tInserted at:" Opened)
(foreach j (cadr i)
(setq Data (entget j))
(write-line (strcat "\t\tLayout: " (cdr (assoc 410 Data))) Opened)
(write-line (strcat "\t\tInsertion point: " (vl-princ-to-string (cdr (assoc 10 Data)))) Opened)
(write-line (strcat "\t\tScale[X Y Z]: " (rtos (cdr (assoc 41 Data))) " " (rtos (cdr (assoc 42 Data))) " " (rtos (cdr (assoc 43 Data)))) Opened)
(write-line (strcat "\t\tRotation: " (rtos (cdr (assoc 50 Data)))) Opened)
(write-line (strcat "\t\tLayer: " (cdr (assoc 8 Data))) Opened)
)
(write-line "\tNested xrefs:" Opened)
(foreach j (caddr i)
(write-line (strcat "\t\t" (cdr (assoc 2 (entget j)))) Opened)
)
)
(close Opened)
(startapp "notepad.exe" Path)
(prompt (strcat "\n Report at: " Path))

)
(prompt "\n No xrefs within drawing.")
)
(princ)
)
(c:XrefTree)
(c:pxi)

;;; Count amount of xrefs in the drawing
;;; Saved from: http://www.theswamp.org/index.php?topic=28062.msg337119#msg337119
;;; original routine by Tim Willey
;;; Slightly modified by igal Averbuh 2018 (added print report to text file and opening output file in notepad)

(defun GetXrefs (/ tempData tempEnt XrefList)

(while (setq tempData (tblnext "block" (not tempData)))
(if (equal (logand (cdr (assoc 70 tempData)) 4) 4)
(progn
(setq tempEnt (tblobjname "block" (cdr (assoc 2 tempData))))
(setq tempData (entget (cdr (assoc 330 (entget tempEnt)))))
(setq XrefList
(cons
(cons
tempEnt
(
(lambda ( x / InsList NestList )
(foreach i x
(cond
((and
(equal (car i) 331)
(entget (cdr i))
)
(setq InsList (cons (cdr i) InsList))
)
((equal (car i) 332)
(setq NestList (cons (cdr i) NestList))
)
)
)
(list InsList NestList)
)
(member '(102 . "{BLKREFS") tempData)
)
)
XrefList
)
)
)
)
)
XrefList
)

(foreach i (GetXrefs)
(princ "\nXref name: ")
(princ (cdr (assoc 2 (entget (car i)))))
(princ "\n Inserted amount: ")
(princ (itoa (length (cadr i))))
(if (caddr i)
(progn
(princ "\n Nested xref names: ")
(foreach j (caddr i)
(princ "\n ")
(princ (cdr (assoc 2 (entget j))))
)
)
)
(princ "\n")
)

(setq Openedd (open (setq Path (strcat (getvar 'DwgPrefix) (vl-filename-base (getvar 'DwgName)) "_Xref-Count.txt")) "w"))

(foreach i (GetXrefs)
(write-line (strcat "\nXref name: ") Openedd)
(write-line (strcat "\t\t" (cdr (assoc 2 (entget (car i))))) Openedd)
(write-line (strcat "\n Inserted amount: ") Openedd)
(write-line (strcat "\t\t" (itoa (length (cadr i)))) Openedd)
(if (caddr i)
(progn
(write-line (strcat "\n Nested xref names: ") Openedd)
(foreach j (caddr i)
(write-line (strcat "\n ") Openedd)
(write-line (strcat "\t\t" (cdr (assoc 2 (entget j)))) Openedd)
)
)
)
(write-line (strcat "\n") Openedd)
)

(close Openedd)
(startapp "notepad.exe" Path)
(prompt (strcat "\n Report at: " Path))

Count amount of xrefs in the drawing

25 Thursday Oct 2018

Posted by danglar71 in Export

≈ Leave a comment


;;; Count amount of xrefs in the drawing
;;; Saved from: http://www.theswamp.org/index.php?topic=28062.msg337119#msg337119
;;; original routine by Tim Willey
;;; Slightly modified by igal Averbuh 2018 (added print report to text file and opening output file in notepad)

(defun GetXrefs (/ tempData tempEnt XrefList)

(while (setq tempData (tblnext "block" (not tempData)))
(if (equal (logand (cdr (assoc 70 tempData)) 4) 4)
(progn
(setq tempEnt (tblobjname "block" (cdr (assoc 2 tempData))))
(setq tempData (entget (cdr (assoc 330 (entget tempEnt)))))
(setq XrefList
(cons
(cons
tempEnt
(
(lambda ( x / InsList NestList )
(foreach i x
(cond
((and
(equal (car i) 331)
(entget (cdr i))
)
(setq InsList (cons (cdr i) InsList))
)
((equal (car i) 332)
(setq NestList (cons (cdr i) NestList))
)
)
)
(list InsList NestList)
)
(member '(102 . "{BLKREFS") tempData)
)
)
XrefList
)
)
)
)
)
XrefList
)

(foreach i (GetXrefs)
(princ "\nXref name: ")
(princ (cdr (assoc 2 (entget (car i)))))
(princ "\n Inserted amount: ")
(princ (itoa (length (cadr i))))
(if (caddr i)
(progn
(princ "\n Nested xref names: ")
(foreach j (caddr i)
(princ "\n ")
(princ (cdr (assoc 2 (entget j))))
)
)
)
(princ "\n")
)

(setq Openedd (open (setq Path (strcat (getvar 'DwgPrefix) (vl-filename-base (getvar 'DwgName)) "_Xref-Count.txt")) "w"))

(foreach i (GetXrefs)
(write-line (strcat "\nXref name: ") Openedd)
(write-line (strcat "\t\t" (cdr (assoc 2 (entget (car i))))) Openedd)
(write-line (strcat "\n Inserted amount: ") Openedd)
(write-line (strcat "\t\t" (itoa (length (cadr i)))) Openedd)
(if (caddr i)
(progn
(write-line (strcat "\n Nested xref names: ") Openedd)
(foreach j (caddr i)
(write-line (strcat "\n ") Openedd)
(write-line (strcat "\t\t" (cdr (assoc 2 (entget j)))) Openedd)
)
)
)
(write-line (strcat "\n") Openedd)
)

(close Openedd)
(startapp "notepad.exe" Path)
(prompt (strcat "\n Report at: " Path))

Print Xref/Block Nesting

25 Thursday Oct 2018

Posted by danglar71 in Export

≈ Leave a comment


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Print Xref/Block Nesting ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; http://www.theswamp.org/index.php?topic=28062.msg337119#msg337119
;;; original routine by Tim Willey
;;; major editing by Marko Ribar
;;; Prints nested block tree to command line, no matter how deep the nesting.
;;; edited by Gary Fowler
;;; Added output file with project header and routine progress bar and paths info
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:PIT ( / Flatten xrefs-list ARCH:DATE2 mainfilter filter nestedblockcount FilterNestedBlocks filternested GetBlockNesting n kk k datestring FileName opened PrintNestedList projectDesc projectName ACET:UI-PROGRESS-FACTOR )

(vl-load-com)

(defun Flatten ( l )
(if (atom l) (list l)
(append (Flatten (car l)) (if (cdr l) (Flatten (cdr l))))
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun xrefs-list nil
(write-line (strcat "\n List Of Saved Xref Paths:") opened)
(write-line "----------------------------------------------------------------------" opened)
(vlax-for
objFileDep
(vla-get-filedependencies
(vla-get-activedocument
(vlax-get-acad-object)
)
)
(if (= "Acad:XRef" (vla-get-feature objFileDep))
(write-line
(strcat " " (vla-get-fullfilename objFileDep))
opened
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ARCH:DATE2 (/ DATST MON DAY YEAR HRS MON2 NHRS XTR)
(setq DATST (rtos (getvar "CDATE") 2 16)
MON (substr DATST 5 2)
DAY (substr DATST 7 2)
YEAR (substr DATST 1 4)
HRS (atoi (substr DATST 10 2))
)
(cond
( (= MON "01") (setq MON2 "January") )
( (= MON "02") (setq MON2 "Feburary") )
( (= MON "03") (setq MON2 "March") )
( (= MON "04") (setq MON2 "April") )
( (= MON "05") (setq MON2 "May") )
( (= MON "06") (setq MON2 "June") )
( (= MON "07") (setq MON2 "July") )
( (= MON "08") (setq MON2 "August") )
( (= MON "09") (setq MON2 "September") )
( (= MON "10") (setq MON2 "October") )
( (= MON "11") (setq MON2 "November") )
( (= MON "12") (setq MON2 "December") )
)
(cond
( (= HRS 00) (setq NHRS (itoa (+ HRS 12))) (setq XTR "a.m.") )
( ( HRS 12) (setq NHRS (itoa (- HRS 12))) (setq XTR "p.m.") )
)
(setq datestring (strcat MON2 " " DAY ", " YEAR " " NHRS ":" (substr DATST 12 2) " " XTR))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq mainfilter
(getstring
T
"\n* Input prefix filter for Main Blocks: [*] "
)
)
(if (= mainfilter "")
(setq mainfilter "*")
)
(setq filter
(getstring T
"\n* Input prefix filter for Nested Blocks: [*] "
)
)
(if (= filter "")
(setq filter "*")
)
(prompt "* Please Wait while the Program is Running...")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun nestedblockcount ( mainname nestedname / bl item n )
(setq bl (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))
(vlax-for item bl
(if (= (vla-get-name item) mainname)
(progn
(setq n 0)
(vlax-for b item
(if (= (vl-catch-all-apply 'vla-get-EffectiveName (list b)) nestedname)
(setq n (1+ n))
)
)
)
)
)
n
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun FilterNestedBlocks ( lst mainfilter filter / ifillst inewlst newlst )
(foreach i lst
(if (and (atom (car i)) (wcmatch (strcase (cdr (assoc 2 (entget (car i))))) (strcase mainfilter)))
(progn
(if (listp (cdr i))
(progn
(setq ifillst (filternested (cdr i) filter))
(setq inewlst (cons (car i) ifillst))
(setq newlst (cons inewlst newlst))
)
(setq newlst (cons i newlst))
)
)
)
)
(reverse newlst)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun filternested ( lst filter / newlst ii )
(foreach i lst
(setq ii i)
(if (not (and (atom (car i)) (wcmatch (strcase (cdr (assoc 2 (entget (car i))))) (strcase filter))))
(setq ii nil)
)
(cond
( (if (and (listp (cdr i)) (member (car i) ii)) (filternested (cdr i) filter) (setq ii nil)) )
( (and (atom (cdr i)) (not (eq (cdr i) nil)))
nil
)
( (eq (cdr i) nil)
nil
)
)
(setq newlst (cons ii newlst))
)
(reverse newlst)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun GetBlockNesting ( / checknestinserts GetBlockInfo tempData def BlockList objBlocks )

(defun checknestinserts ( def / f )
(vlax-for obj def
(if (= (cdr (assoc 0 (entget (vlax-vla-object->ename obj)))) "INSERT")
(setq f t)
)
)
f
)

(defun GetBlockInfo ( def / uniqueref refl NestList )

(defun uniqueref ( l )
(if l (cons (car l) (uniqueref (vl-remove-if '(lambda ( x ) (= (vla-get-name x) (vla-get-name (car l)))) l))))
)

(vlax-for obj def
(if (= (cdr (assoc 0 (entget (vlax-vla-object->ename obj)))) "INSERT")
(setq refl (cons obj refl))
)
)
(setq refl (reverse refl))
(setq refl (uniqueref refl))
(foreach obj refl
(if (not (checknestinserts (vla-item objBlocks (vla-get-name obj))))
(setq NestList (cons (list (vlax-vla-object->ename obj)) NestList))
(setq NestList (cons (cons (vlax-vla-object->ename obj) (GetBlockInfo (vla-item objBlocks (vla-get-name obj)))) NestList))
)
)
NestList
)

(while (setq tempData (tblnext "BLOCK" (not tempData)))
(if (assoc 102 (entget (cdr (assoc 330 (entget (tblobjname "BLOCK" (cdr (assoc 2 tempData))))))))
(progn
(setq def (vla-item (setq objBlocks (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))) (cdr (assoc 2 tempData))))
(setq names nil name nil)
(setq BlockList
(cons
(cons
(vlax-vla-object->ename def)
(GetBlockInfo def)
)
BlockList
)
)
)
)
)
BlockList
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq n 1)
(ACET-UI-PROGRESS-INIT
"Please Wait while the Program is Running"
(length
(Flatten
(progn
(setq kk nil)
(foreach k (vl-remove nil (FilterNestedBlocks (GetBlockNesting) mainfilter filter))
(setq k (vl-remove nil k))
(setq kk (cons k kk))
)
(reverse kk)
)
)
)
)
(ARCH:DATE2)
(setq FileName (substr (getvar "dwgname") 1 (- (strlen (getvar "dwgname")) 4)))
(setq opened (open (strcat (getvar "dwgprefix") FileName " PrintNesting.txt") "w"))
(write-line
"----------------------------------------------------------------------"
opened
)
(write-line (strcat " Directory is: [" (getvar "dwgprefix") FileName "]") opened)
(write-line (strcat " " datestring) opened)
(write-line
"----------------------------------------------------------------------"
opened
)

(defun PrintNestedList ( lst spc mainname / lstn k kk )
(foreach i (setq lstn (vl-sort lst (function (lambda ( a b ) (vla-object (car i))))))
(write-line
(strcat "" spc " Nested xref: " (cdr (assoc 2 (entget (car i)))) " - " (itoa (nestedblockcount mainname (cdr (assoc 2 (entget (car i)))))))
opened
)
(write-line
(strcat "" spc " Nested block: " (cdr (assoc 2 (entget (car i)))) " - " (itoa (nestedblockcount mainname (cdr (assoc 2 (entget (car i)))))))
opened
)
)
(prompt (strcat "\n" spc " Nested block: nil"))
)
(PrintNestedList
(if (cdr i)
(cdr i)
nil
)
(strcat " " spc)
(cdr (assoc 2 (entget (car i))))
)
(ACET-UI-PROGRESS-SAFE n)
(setq n (1+ n))
)
(setq k 0)
(foreach i lstn
(setq k (+ k (nestedblockcount mainname (cdr (assoc 2 (entget (car i)))))))
)
(if lstn (write-line (strcat spc " *** Total count per branch : " (itoa k) " *** ") opened))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(foreach i
(vl-sort
(progn
(setq kk nil)
(foreach k (vl-remove nil (FilterNestedBlocks (GetBlockNesting) mainfilter filter))
(setq k (vl-remove nil k))
(setq kk (cons k kk))
)
(reverse kk)
)
(function
(lambda ( a b )
(vla-object (car i))))))
(write-line
(strcat "\n [ ] Main xref: " (cdr (assoc 2 (entget (car i)))) " - " (itoa (sslength (ssget "_A" (list '(0 . "INSERT") (assoc 2 (entget (car i))) (cons 410 (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")))))))
opened
)
(write-line
(strcat "\n [ ] Main block: " (cdr (assoc 2 (entget (car i)))) " - " (itoa (sslength (ssget "_A" (list '(0 . "INSERT") (assoc 2 (entget (car i))) (cons 410 (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")))))))
opened
)
)
(ACET-UI-PROGRESS-SAFE n)
(setq n (1+ n))
(PrintNestedList
(if (and (/= (cadr i) nil) (cdr i))
(vl-remove nil (cdr i))
)
" >"
(cdr (assoc 2 (entget (car i))))
)
)
)
)

(if Opened
(close Opened)
)
(startapp "notepad.exe"
(strcat (getvar "dwgprefix")
FileName
" PrintNesting.txt"
)
)
(ACET-UI-PROGRESS-DONE)
(princ)
)
(c:pit)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Insert DWG’s from a folder as blocks

25 Thursday Oct 2018

Posted by danglar71 in Import

≈ Leave a comment


;Insert DWG's from a folder as blocks
;updates by CAD Studio
(defun c:Ins (/ d doc lst pt pt1 dir b blk blkn ex xx)
(vl-load-com)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(if
(and (setq
dir (vl-filename-directory
(getfiled "Select a DWG for folder" (getvar 'dwgprefix) "dwg" 8)
)
)
(setq lst (vl-directory-files dir "*.dwg"))
(setq xx (princ (strcat "\n" (itoa (length lst)) " blocks found")))
(setq pt1 (getpoint "\nSelect ins.point for first block: "))
(setq d
(distance (getpoint pt1 "\nSelect distance as second point to space blocks (or 0,0): ")
pt1
)
)
(setq ex (= "Y" (strcase (getstring "\nExplode inserted blocks? [Y/N] : "))) xx T)
)
(foreach b lst
(princ (strcat "\n" b " "))
(setq blk (vla-insertblock
(if (= (getvar 'cvport) 1)
(vla-get-paperspace doc)
(vla-get-modelspace doc)
)
(vlax-3d-point (setq pt1 (polar pt1 0.0 d)))
(strcat dir "\\" b)
1
1
1
0.0
));insert, setq
(if ex (progn
(princ " exploding")
(setq blkn (vla-get-effectivename blk))
(vl-catch-all-apply 'vla-explode (list blk)) (vl-catch-all-apply 'vla-delete (list blk))
(vl-catch-all-apply 'vla-delete (list (vla-item (vla-get-blocks doc) blkn)))
))
); for
)
(princ "Done.")
(princ)
)
(c:ins)

Draw Filled Rotated Envelope – EF

22 Monday Oct 2018

Posted by danglar71 in draw

≈ Leave a comment


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

Make Layer Current by Selecting object – TDS

22 Monday Oct 2018

Posted by danglar71 in Layers

≈ Leave a comment


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

← Older posts

Recent Posts

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

Recent Comments

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

Archives

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

Categories

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

Recent Posts

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

Recent Comments

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

Archives

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

Categories

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

Create a free website or blog at WordPress.com.

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