AutoLISP Code


ron.lsp
; Copyright (c) 2006
; Ronald Peterson
; (Y) Yellowbank
; All rights reserved.  Applicable GPL license terms can be found in
; the associated LICENSE file.

(setvar "STARTUPTODAY" 0)

(setq MESS "\nLoaded RON.LSP")

;DND Variables-----------------------------------------------------------------
(setq TAG_AREA "AREA")
(setq TAG_LAYER "LAYER")
(setq TAG_DWGFILE "DWGNAME")
(setq TAG_SPACEID "SPACEID")
(setq DND_DATA_LAYERS "P:/DNDSPACE/CAD/PDFLLIST.TXT")
(setq DNDDATA_FILENAME "P:/DNDSPACE/CAD/CADDATA.CSV")
(setq REDUCTION_FACTOR 0.025)
(setq AREA_FACTOR 144.0)

(if (wcmatch (getvar "ACADVER") "*14*")
				 (setq PL_NAME "LWPOLYLINE")
	(setq PL_NAME "POLYLINE")
)

(setq LAYER_STATE '())
(setq LAYER_STATE_2 '())

(setq DATETAG "PLOTDATE")
(setq DWGNAMETAG "DWGNAME")
(setq DRAWNBYTAG "DRAWNBY") ;NOT USED - PUT IN 'DATETAG'
(setq XREFTAG "XREFS")
(setq TBLOCKLST '("-DWGINFO" "-TITTEXT" "T-TEXT" "T-T2234" "T1711T" "T3422T" "T-T3042" "T-T2234M" "SK8X11" "SKD8X11"))

(setq COMMENT_FLAGS '(";" "/"))
;-----------------------------------------------------------------------------


(defun c:it()
	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(insert_tiff)
	(command ".undo" "end")
	(sysvarrestore)
	(prin1)
)

(setq PICXSIZE 8000) ; in pixels
(setq PICYSIZE 8000) ; in pixels
(defun insert_tiff (/ fname f xscale rot1 rot2 insx insy xpixels ypixels tname xsize ysize)
	(setq fname (getfiled "Tiff Placement File"
					  "filename.tfw"
					  "tfw"
					  0))
	(setq f (open fname "r"))
	(setq xscale (atof (read-line f)))
	(setq rot1 (atof (read-line f))) // not used
	(setq rot2 (atof (read-line f))) // not used
	(setq yscale (- 0 (atof (read-line f))))
	(setq insx (atof (read-line f)))
	(setq insy (atof (read-line f)))
	(close f)

	(setq xpixels (getint (strcat "\nImage pixel width <" (itoa PICXSIZE) ">:  ")))
	(if (equal xpixels '())
		(setq xpixels PICXSIZE)
	)
	(setq PICXSIZE xpixels)

	(setq ypixels (getint (strcat "\nImage pixel width <" (itoa PICYSIZE) ">:  ")))
	(if (equal ypixels '())
		(setq ypixels PICYSIZE)
	)
	(setq PICYSIZE ypixels)

	(setq tname (strcat (string_remove fname "" "tfw") "tif"))
	(setq xsize (* xpixels xscale)) ; this is also the overall scale factor
	(setq ysize (* ypixels xscale))
	(setq insy (- insy ysize))

	(command "._image" "attach" tname (list insx insy) xsize 0)
)

; put a file named "xreffix.txt" in root project folder.
; this should be a comma-separated file
; it should have one line, of the form:
; ,
; where oldpath and new path indicate previous xref path prefix, and
; new xref path prefix to use instead

(defun c:fx()
	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(fix_xrefs)
	(command ".undo" "end")
	(sysvarrestore)
	(prin1)
)

(defun fix_xrefs(/ xrefs curr_dir proj_dir pathsub xref)
	(prompt "\nChanging xref paths")
	(setq xrefs (list_xrefs_notfound))
	(setq curr_dir (getvar "DWGPREFIX"))
	(setq proj_dir (root_folder curr_dir 2))
	(setq pathsub (read_cdf_s2 (strcat proj_dir "xreffix.txt")))
	(foreach xref xrefs
		(setq xrefshort (path_strip xref))
		(setq xref (change_path xref (caar pathsub) (cadar pathsub)))
		(prompt (strcat "\nUpdating xref "
					 (strcase xrefshort)
					 " to path "
					 (strcase xref)))
		(command ".xref" "path" xrefshort xref)
	)
)

(defun change_path( fname oldpre newpre / oldlen suffix )
	(setq oldlen (strlen oldpre))
	(setq suffix (substr fname (1+ oldlen)))
	(strcat newpre suffix)
)

(defun root_folder(dir depth / root c)
	(setq root (substr dir 1 3))
	(setq d 0)
	(setq dir (substr dir 4))
	(setq c "")
	(while (and (< d depth) (not (equal dir "")))
		(setq c (substr dir 1 1))
		(if (equal c "\\")
			(progn
				(setq d (1+ d))
				(setq root (strcat root "\\"))
				(setq dir (substr dir 2))
			)
			(progn
				(setq root (strcat root c))
				(setq dir (substr dir 2))
			)
		)
	)
	root
)

(defun c:dh()
	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(command ".ucs" "world")
	(define_hatch)
	(command ".ucs" "prev")
	(command ".undo" "end")
	(sysvarrestore)
	(prin1)
)

(defun define_hatch()
	(prompt "\nDefine Hatch...")
	(prompt "\nSelect lines: ")
	(setq ss (ssget '((0 . "LINE"))))
	(setq ll (getpoint "\nLower left corner of bounding rectangle: "))
	(setq ur (getpoint ll "\nUpper right corner of bounding rectangle: "))
	(setq cp (mapcar '- ur ll))
	(setq ndx (sslength ss))
	(while (>= (setq ndx (1- ndx)) 0)
		(setq le (ssname ss ndx))
		(setq ld (entget le))
		(setq p1 (cdr (assoc 10 ld)) p2 (cdr (assoc 11 ld)))
		(if (< (cadr p2) (cadr p1))
			(setq pl p2 pu p1)
			(setq pl p1 pu p2)
		) ; pl - lower point, pu - upper point

		(setq angr (angle pl pu))
		(setq o-ang (radtodeg angr))
		(setq o-x (car pl))
		(setq o-y (cadr pl))
		(command ".ucs" "z" o-ang)
		(setq llt (trans ll 0 1))
		(setq urt (trans ur 0 1))
		(setq o-dx (abs (- (car llt) (car urt))))
		(setq o-dy (abs (- (cadr llt) (cadr urt))))
		(setq o-pd (distance pl pu))

		(setq tp (rotate_point cp ))
		(setq dx (car tp))
		(setq dy (cadr tp))
	)
)

; clip infinite line defined by pt1 and pt2 by rectangle defined by ll and ur
; ditto for line perpendicular to pt1 and pt2.  return lengths.
(defun span_dist( pt1 pt2 ll ur / lr ul xmax ymax xmin ymin ir iu il ib
						    iry iux ily ibx ppl tpl p)
	(setq lr (list (car ur) (cadr ll)))
	(setq ul (list (car ll) (cadr ur)))

	(setq xmax (car ur))
	(setq ymax (cadr ur))
	(setq xmin (car ll))
	(setq ymin (cadr ll))

	(setq ir (inters pt1 pt2 lr ur '()))
	(setq iu (inters pt1 pt2 ul ur '()))
	(setq il (inters pt1 pt2 ul ll '()))
	(setq ib (inters pt1 pt2 lr ll '())) ; b for bottom, since l is also left

	(if (> (distance ir il) (distance iu ib))
		(setq ppl (list iu ib))
		(setq ppl (list ir il))
	)

;	(setq iry (cadr ir))
;	(if (or (> iry ymax) (< iry ymin)) (setq ir '()))
;	(setq iux (car iu))
;	(if (or (> iux xmax) (< iux xmin)) (setq iu '()))
;	(setq ily (cadr il))
;	(if (or (> ily ymax) (< ily ymin)) (setq il '()))
;	(setq ibx (car ib))
;	(if (or (> ibx xmax) (< ibx xmin)) (setq ib '()))

;	(setq ppl '()) ; parallel point list
;	(setq tpl (list ir iu il ib))
;	(foreach p tpl
;		(if p
;			(if (not (member p ppl))
;				(setq ppl (cons p ppl))
;			)
;		)
;	)
	ppl
)

(defun radtodeg (rad)
	(* rad (/ 360.0 (* 2.0 PI)))
)

;rotate point around 0,0 w/ ang in radians
(defun rotate_point (pt ang) 
	(setq d (distance '(0.0 0.0) pt))
	(setq a (angle '(0.0 0.0) pt))
	(setq a (+ a ang))
	(polar pt a d)
)

(defun c:mbi()
	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(move_block_insert)
	(command ".undo" "end")
	(sysvarrestore)
	(prin1)
)

(defun move_block_insert (/ ss ni ndx be bd ins)
	(prompt "\nSelect blocks:  ")
	(setq ss (ssget '((0 . "INSERT"))))
	(setq ni (getpoint "\nPoint to move blocks to:  "))
	(setq ndx (sslength ss))
	(while (>= (setq ndx (1- ndx)) 0)
		(setq be (ssname ss ndx))
		(setq bd (entget be))
		(setq ins (cdr (assoc 10 bd)))
		(command ".move" be "" (trans ins 0 1) ni)
	)
)

;-----------------------------------------------------------------------------
(defun c:lf()
	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(list_fonts)
	(command ".undo" "end")
	(sysvarrestore)
	(prin1)
)

(defun list_fonts(/ fl f pf bf font)
	(setq fl '())
	(setq f (tblnext "STYLE" T))
	(setq pf (cdr (assoc 3 f)))
	(setq bf (cdr (assoc 4 f)))
	(if (not (member pf fl))
		(setq fl (cons pf fl))
	)
	(if (not (member bf fl))
		(setq fl (cons bf fl))
	)
	(while (setq f (tblnext "STYLE"))
		(setq pf (cdr (assoc 3 f)))
		(setq bf (cdr (assoc 4 f)))
		(if (not (member pf fl))
			(setq fl (cons pf fl))
		)
		(if (not (member bf fl))
			(setq fl (cons bf fl))
		)
	)
	(foreach font fl
		(prompt (strcat "\n" font))
	)
)

(defun c:lw2p()
	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(lwp2p)
	(command ".undo" "end")
	(sysvarrestore)
	(prin1)
)

(defun lwp2p(/ ss ndx pe)
	(prompt "\nSelect LWPOLYLINES to convert to POLYLINES:  ")
	(setq ss (ssget '((0 . "LWPOLYLINE"))))
	(setq ndx (sslength ss))
	(while (>= (setq ndx (1- ndx)) 0)
		(setq pe (ssname ss ndx))
		(lwpoly_to_poly pe)
	)
)

(defun lwpoly_to_poly( pe / pd la v_list v pd ph pf )
	(setq pd (entget pe))
	(setq la (cdr (assoc 8 pd)))
	(setq flags (assoc 70 pd))
	(setq v_list '())
	(while (setq v (assoc 10 pd))
		(setq pd (cdr (member v pd)))
		(setq v_list (cons (list '(0 . "VERTEX") (cons 8 la) v) v_list))
	)
	(setq ph (list '(0 . "POLYLINE") (cons 8 la) flags))
	(setq pf (list '(0 . "SEQEND")))
	(entdel pe)
	(entmake ph)
	(foreach v v_list (entmake v))
	(entmake pf)
)

;-----------------------------------------------------------------------------
(defun c:stp(/ p x y)
	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(spline_to_polyline)
	(command ".undo" "end")
	(sysvarrestore)
	(prin1)
)

(defun spline_to_polyline (/ ptlist ss ndx se sd pt)
	(prompt "\nSelect SPLINE entities to convert to polylines:  ")
	(setq ss (ssget '((0 . "SPLINE"))))
	(setq ndx (sslength ss))
	(while (>= (setq ndx (1- ndx)) 0)
		(setq ptlist '())
		(setq se (ssname ss ndx))
		(setq sd (entget se))
		(setq sl (cdr (assoc 8 sd)))
		(command ".layer" "set" sl "")
		(while (setq pt (assoc 10 sd))
			(setq sd (cdr (member pt sd)))
			(setq pt (cdr pt))
			(setq ptlist (cons pt ptlist))
		)
		(entdel se)
		(draw_pline ptlist)
	)
)

(defun c:mml(/ p x y)
	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(measure_multiple_lines)
	(command ".undo" "end")
	(sysvarrestore)
	(prin1)
)

(defun measure_multiple_lines ()
	(prompt "\nSelect lines and polylines to measure:  ")
	(setq ss (ssget (list '(-4 . "")))
	)
	(setq bname (getstring "\nBlock name to insert:  "))
	(setq dist (getdist "\nDistance between objects:  "))

	(setq ndx (sslength ss))
	(while (>= (setq ndx (1- ndx)) 0)
		(setq le (ssname ss ndx))
		(command ".measure"
			(list le '(0.0 0.0 0.0))
			"b"
			bname
			""
			dist
		)
	)
)


(defun c:wtd()
	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(write_text_data)
	(command ".undo" "end")
	(sysvarrestore)
	(prin1)
)

(defun write_text_data (/ fname f ss ndx te td txt)
	(setq fname (getfiled "Delimited Text File"
					  "filename.csv"
					  "csv"
					  1))
	(setq f (open fname "w"))
	(prompt "\nSelect text and mtext:  ")
	(setq ss (ssget '((-4 . ""))))
	(setq ndx (sslength ss))
	(while (>= (setq ndx (1- ndx)) 0)
		(setq te (ssname ss ndx))
		(setq td (entget te))
		(setq txt (cdr (assoc 1 td)))
		(write-line txt f)
	)
	(close f)
)

(defun c:wld(/ p x y)
	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(write_link_data)
	(command ".undo" "end")
	(sysvarrestore)
	(prin1)
)

(defun write_link_data (/ fname f ss ndx e ed lay han et col lc are len str)
	(prompt "\nSelect lines and polylines to write data for:  ")
	(setq fname (getfiled "Delimited Text File"
					  "filename.csv"
					  "csv"
					  1))
	(setq f (open fname "w"))
	(setq str (make_cdf (list "handle"
						 "entity type"
						 "layer"
						 "entity color"
						 "layer color"
						 "area"
						 "width"
						 "length")))
	(write-line str f)
	(setq ss (ssget (list '(-4 . "")))
	)
	(setq ndx (sslength ss))
	(while (>= (setq ndx (1- ndx)) 0)
		(setq e (ssname ss ndx))
		(setq ed (entget e))
		(setq lay (cdr (assoc 8 ed)))
		(setq han (cdr (assoc 5 ed)))
		(setq et (cdr (assoc 0 ed)))
		(setq col (get_entity_color ed))
		(setq lc (get_layer_color lay))
		(if (not (equal et "LINE"))
			(setq are (get_area e)) ; assumes unit is an inch
			(setq are "line")
		)
		(setq wid (get_width ed))
		(setq len (get_length e))
		(setq str (make_cdf (list han et lay col lc are wid len)))
		(write-line str f)
	)
	(close f)
)

(defun get_width (ed / et wid wd)
	(setq et (cdr (assoc 0 ed)))
	(setq wid 0)
	(if (or (equal et "POLYLINE") (equal et "LWPOLYLINE"))
		(if (setq wd (assoc 40 ed))
			(setq wid (cdr wd))
		)
	)
	(rtos wid 2)
)

(defun get_layer_color (lay / ld)
	(setq ld (tblsearch "LAYER" lay))
	(itoa (cdr (assoc 62 ld)))
)

(defun get_area (en / c ret a)
	(setq c (cdr (assoc 70 (entget en))))
	(if (not (bit_check c (list 1)));polyline is not closed
		(setq ret "unclosed")
		(progn
			(command ".area" "e" (list en '(0 0 0)))
			(setq a (getvar "AREA"))
			(setq ret (rtos a 2))
		)
	)
	ret
)

(defun get_length (en / ed p1 p2 a)
	(if (equal (cdr (assoc 0 (setq ed (entget en)))) "LINE")
		(progn
			(setq p1 (cdr (assoc 10 ed)))
			(setq p2 (cdr (assoc 11 ed)))
			(setq a (distance p1 p2))
		)
		(progn
			(command ".area" "e" (list en '(0 0 0)))
			(setq a (getvar "PERIMETER"))
		)
	)
	(rtos a 2)
)

(defun get_entity_color (ed / col)
	(if (setq col (assoc 62 ed))
		(progn
			(setq col (cdr col))
			(if (equal col 0)
				(setq col "BYBLOCK")
				(setq col (itoa col))
			)
		)
		(setq col "BYLAYER")
	)
	col
)

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

(defun c:ftid(/ p x y)
	(setq p (getpoint "\nPick a point:  "))
	(setq x (car p))
	(setq y (cadr p))
	(setq x (rtos x))
	(setq y (rtos y))
	(prompt (strcat "\nX: " x "\tY: " y))
	(prin1)
)


;------------------------------------------------------------------------------
(defun c:wbcsv () ;write block insertion points to csv file
	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(write_block_insertion_to_csv)
	(command ".undo" "end")
	(sysvarrestore)
	(prin1)
)

(defun write_block_insertion_to_csv(/ ss fname f ndx be ins str)
	(prompt "\nSelect blocks to write insertion points to csv file...")
	(setq ss (ssget '((0 . "INSERT"))))
	(setq fname (getfiled "Delimited Text File"
					  "filename.csv"
					  "csv"
					  1))
	(setq f (open fname "w"))
	(setq ndx (sslength ss))
	(while (>= (setq ndx (1- ndx)) 0)
		(setq be (ssname ss ndx))
		(setq ins (cdr (assoc 10 (entget be))))
		(setq str (make_cdf (list (rtos (car ins) 2 1) (rtos (cadr ins) 2 1) (rtos (caddr ins) 2 1))))
		(write-line str f)
	)
	(close f)
)


;read a list of vertices to create planar regions
;used to help convert GDS 3D drawings into AutoCAD
(defun c:vltr () ;vertex list to regions
;	(sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode"))
	(command ".undo" "group")
	(vertex_list_to_regions)
	(command ".undo" "end")
;	(sysvarrestore)
	(prin1)
)

(defun vertex_list_to_regions(/ fname vll vl v rorp)
;	(setq vll (read_cdf_n "Vertices" "txt"))
	(setq fname (getstring "\nVertex list filename:  "))
	(setq vll (read_cdf_n2 fname))
	(initget "Polylines Regions")
	(setq rorp (getkword "\nDraw Regions or 

olylines: ")) (if (equal rorp '()) (setq rorp "Polylines")) (setq vll (vll_massage vll)) (foreach vl vll (if (equal (type vl) 'STR) (command ".layer" "make" vl "") (progn (command ".ucs" "3" (car vl) (cadr vl) (caddr vl)) (setq vl (cdddr vl)) (command ".pline") (foreach v vl (command (trans v 0 1)) ) (command "c") (command ".ucs" "p") (if (equal rorp "Regions") ; (command ".region" "last" "") (command ".region" (entlast) "") ) ) ) ) ) ;translate flat list of vertices into list of vertex lists (defun vll_massage( vl / vll vlt v) (prompt "\nReorganizing vertex list...") (setq vll '()) (setq vlt '()) (foreach v vl (cond ((equal (car v) '()) (if (>= (length vlt) 3) (setq vll (append vll (list vlt))) ) (setq vlt '()) ) ((equal (type (car v)) 'REAL) (setq vlt (append vlt (list v))) ) ((equal (type (car v)) 'STR) (if (not (member (substr (car v) 1 1) COMMENT_FLAGS)) (setq vll (append vll (list (car v)))) ) ) ) ) vll (setq testit vll) ) ;------------------------------------------------------------------------------ (defun c:uxp () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (prompt "\nUpdating xref paths to match current directory...") (update_xref_paths) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun update_xref_paths (/ xrefs curr_dir xref) (setq xrefs (list_all_xrefs)) (setq curr_dir (getvar "DWGPREFIX")) (foreach xref xrefs (prompt (strcat "\nUpdating xref " (strcase xref))) (command ".xref" "path" xref (strcat curr_dir xref)) ) ) (defun c:cc () ;Color closed polylines (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (color_closed_polylines) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun color_closed_polylines(/ ss mycolor ndx pe cflag pe c) (prompt "\Select polylines for which you want to color closed ones: ") (setq ss (ssget '((-4 . "")))) (setq mycolor (getint "\nColor for closed polylines: ")) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq pe (ssname ss ndx)) (setq pd (entget pe)) (setq c (cdr (assoc 70 pd))) (if (not (bit_check c (list 1)));polyline is not closed (setq cflag "unclosed") (setq cflag "closed") ) (if (equal cflag "closed") (command ".chprop" (list pe '(0.0 0.0 0.0)) "" "color" mycolor "") ) ) ) ;------------------------------------------------------------------------------ (defun c:dts () ;Draw text styles (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (draw_text_styles) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun draw_text_styles(/ ins tsl cs s sn) (prompt "\nDraw text styles.") (setq ins (getpoint "\nStart point: ")) (setq pre (strcase (getstring "\nStyle name prefix: "))) (setq tsl (read_cdf_s "Text style list" "csv")) (setq cs (getvar "TEXTSTYLE")) (foreach s tsl (setq s (strcase (car s))) (setq sn (strcat pre (path_strip s))) (prompt (strcat "\nCreating style " sn)) (command ".style" sn s) (while (> (getvar "CMDACTIVE") 0) (command "") ) (command ".textstyle" cs) (command ".text" ins (/ 1.0 8.0) "0" s) (command ".textstyle" sn) (setq ins (mapcar '+ '(2 0 0) ins)) (command ".text" ins (/ 1.0 8.0) "0" "abcdeABCDE12345") (setq ins (mapcar '+ '(-2 -0.25 0) ins)) ) (command ".textstyle" cs) ) ;------------------------------------------------------------------------------ (defun c:fss () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (font_substitute_single) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun font_substitute_single(/ sl ss ft te td st cs) (prompt "\nSelect text to redefine: ") (setq sl '()) (setq ss (ssget '((0 . "TEXT")))) (setq ft (strcase (getstring "\nFont to use: "))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq te (ssname ss ndx)) (setq td (entget te)) (setq st (cdr (assoc 7 td))) (if (not (member st sl)) (setq sl (cons st sl)) ) ) (prompt "\nRedefining styles") (setq cs (getvar "TEXTSTYLE")) (foreach st sl (prompt (strcat "\n\t" st )) (command ".style" st ft) (while (> (getvar "CMDACTIVE") 0) (command "") ) ) (command ".textstyle" cs) ) ;------------------------------------------------------------------------------ (defun c:fs () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (font_substitute) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun font_substitute() (prompt "\nRedefine text style primary fonts...") (setq fsl (read_cdf_s "Font substitution list" "csv")) (font_substitute_list fsl) ) (defun font_substitute_list (fsl / sl item of nf s) (setq sl (list_style_fonts)) ;style name, primary font, big font (foreach item fsl (setq of (car item)) (setq nf (cadr item)) (foreach s sl (if (equal (strcase of) (cadr s)) (if (not (equal (strcase (car s)) "SANSSERIFBOLD")) (redefine_style_font (car s) (strcase of) (strcase nf)) ) ) ) ) ) (defun redefine_style_font (sn of nf / cs) (prompt (strcat "\nReplacing font " of " with " nf " in text style " sn "...")) (setq cs (getvar "TEXTSTYLE")) (command ".style" sn nf) (while (> (getvar "CMDACTIVE") 0) (command "") ) (command ".textstyle" cs) ) ;------------------------------------------------------------------------------ ;------------------------------------------------------------------------------ ;tren urbano scriplet (defun c:nfc() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (command ".insert" "nfc1-tag=") (command) (command ".regen") (command ".undo" "end") (sysvarrestore) (prin1) ) (defun c:psw() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (polyline_select_window) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun polyline_select_window(/ pe pl) (prompt "\nSelects all entities within a polyline...") (prompt "\nSelect polyline: ") (setq pe (entsel)) (setq pl (make_vertex_pt_list (car pe))) (ssget "wp" pl) (prompt (strcat "\nEntities added to \"previous\" selection.")) ) (defun c:psc() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (polyline_select_crossing) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun polyline_select_crossing(/ pe pl) (prompt "\nSelects all entities within and crossing a polyline...") (prompt "\nSelect polyline: ") (setq pe (entsel)) (setq pl (make_vertex_pt_list (car pe))) (ssget "cp" pl) (prompt (strcat "\nEntities added to \"previous\" selection.")) ) ;tren urbano signage (defun c:pt_select() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (postscript_text_select) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun postscript_text_select(/ sl filt s ss) (setq sl (postscript_text_styles)) (prompt "\nSelect postscript text styles:") (setq filt '((-4 . "OR>"))) (foreach s sl (setq filt (cons (cons 7 s) filt)) (prompt (strcat "\n\t" s)) ) (setq filt (cons '(-4 . "= (setq ndx (1- ndx)) 0) (setq te (ssname ss ndx)) (setq td (entget te)) (setq ins (cdr (assoc 10 td))) (setq h (cdr (assoc 40 td))) (setq m (* h fmove)) (setq m (strcat (rtos m 2 8) ",0.0")) (command ".ucs" "ob" (list te ins)) (command ".move" te "" m "") (command ".ucs" "p") ) ) ) ) (defun select_font_text(font / sl) (setq sl (list_font_styles font)) (select_styles sl) ) (defun list_font_styles(font / ret sl st) (setq ret '()) (setq sl (list_style_fonts)) (foreach st sl (if (equal (cadr st) font) (setq ret (cons (car st) ret)) ) ) ret ) (defun c:font_replace() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (font_replace) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun font_replace(/ sl filt s ss) (font_substitute_list '(("SASB____.PFB" "VELVETNL.SHX"))) (font_substitute_list '(("SAS_____.PFB" "VELVETNL.SHX"))) ; (font_substitute_list '(("SASB____.PFB" "HELV-O.SHX"))) ; (font_substitute_list '(("VELVETNL.SHX" "HELV-O.SHX"))) ) (defun c:pt_resize() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (postscript_text_resize_init) (command ".undo" "end") (sysvarrestore) (prin1) ) ;global variable ; (setq PS_SCALE_FACTOR_DOWN 0.67) ; (setq PS_SCALE_FACTOR_UP (/ 1.0 0.67)) (setq PS_SCALE_FACTOR_DOWN 0.732) (setq PS_SCALE_FACTOR_UP (/ 1.0 0.732)) (defun postscript_text_resize_init() (initget "Up Down") (setq ud (getkword "\nResize postscript text Up or own: ")) (if (equal ud '()) (setq ud "Down")) (postscript_text_resize ud) ) (defun postscript_text_resize (ud / ptsl s ss ndx e ed ins sf) (if (equal ud "Down") (setq sf PS_SCALE_FACTOR_DOWN) (setq sf PS_SCALE_FACTOR_UP) ) (setq ptsl (postscript_text_styles)) (prompt "\nThe following styles use postscript fonts...") (foreach s ptsl (prompt (strcat "\n\t" s)) ) (setq ss (select_styles ptsl)) (if ss (progn (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) (setq ins (cdr (assoc 10 ed))) (command ".scale" e "" ins sf) ) ) ) (if ptsl (resize_block_text ptsl) ) (command ".regen") ) (defun resize_block_text(ptsl / bnames b-name) (setq bnames (list_blocks)) (foreach b-name bnames (prompt (strcat "\nChecking block " b-name "...")) (redef_blk_text b-name ptsl) ) ) (defun redef_blk_text (block_name ptsl / tmp e ss ed ins) ;; Change value of a group code for all entities comprising a ;; a block - recursive. (setq tmp (getvar "EXPERT")) (setvar "EXPERT" 5) (if (equal "12" (acad_ver)) (command ".layer" "unlock" "0" "thaw" "0" "on" "0" "") (command ".layer" "thaw" "0" "on" "0" "") ) (setq e (entlast)) (command ".insert" (strcat "*" block_name) "0,0" 1 "0") (setq ss (ssadd)) (setq e (if e (entnext e) (entnext))) (while e (setq ed (entget e)) (if (and (or (equal (cdr (assoc 0 ed)) "TEXT") (equal (cdr (assoc 0 ed)) "ATTDEF") ) (member (cdr (assoc 7 ed)) ptsl) ) (progn (prompt "\n\tResizing TEXT or ATTDEF...") (setq ins (cdr (assoc 10 ed))) (command ".scale" e "" ins PS_SCALE_FACTOR_DOWN) ) ) (setq ss (ssadd e ss)) (setq e (entnext e)) ) (command ".block" block_name "0,0" ss "") (setvar "EXPERT" tmp) ) (defun postscript_text_styles (/ sfl ps_style_list item sfl pf pfe) (setq sfl (list_style_fonts)) (setq ps_style_list '());list of styles using postscript fonts (foreach item sfl (setq pf (cadr item)); primary font (setq pfe (substr pf (- (strlen pf) 2) 3)) (if (equal pfe "PFB") (setq ps_style_list (cons (car item) ps_style_list)) ) ) ps_style_list ) (defun select_styles(ptsl / ssfilt pts) (setq ssfilt '((-4 . "OR>"))) (foreach pts ptsl (setq ssfilt (cons (cons 7 pts) ssfilt)) ) (setq ssfilt (cons '(-4 . "")) ssfilt)) (ssget "x" ssfilt) ) ;------------------------------------------------------------------------------ ;for tren_urbano (defun c:rem() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (redef_elev_mark) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun redef_elev_mark () (command ".insert" "elv_mark=p:/tren_urb/library/symbols/elv_mark") (command) (command ".regen") ) (defun c:ss() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (save_state_layers 'LAYER_STATE_2) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun save_state_layers(gls / l cl ls ln lf lc) (prompt "\nSaving current layer state. Type RS to restore...") (setq l (tblnext "LAYER" T)) (setq cl (getvar "CLAYER")) (set gls '()) (while l (setq ls '()) (setq ln (cdr (assoc 2 l))) (setq lf (cdr (assoc 70 l))); flags. 1:frozen, 2:frozen in new viewports, 4:locked (setq lc (cdr (assoc 62 l))); color. if negative, layer is off (if (bit_check lf (list 1)) (setq ls (list "freeze")) (setq ls (list "thaw")) ) (if (equal (abs lc) lc) (setq ls (cons "on" ls)) (setq ls (cons "off" ls)) ) (setq ls (cons ln ls)) (set gls (cons ls (eval gls))) (setq l (tblnext "LAYER")) ) ) (defun c:rs() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (restore_state_layers LAYER_STATE) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun c:rs2() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (restore_state_layers LAYER_STATE_2) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun restore_state_layers(ls / cl l ln oo ft ld lc lf ooc ftc) (setq cl (getvar "CLAYER")) (command ".layer") ; (setq l (assoc cl ls)) ; (command (cadr l) (car l) (caddr l) (car l)) ; (command "set" (car l)) (foreach l ls (setq ln (car l)) (setq oo (cadr l)) (setq ft (caddr l)) (setq ld (tblsearch "LAYER" ln)) (setq lc (cdr (assoc 62 ld))) (setq lf (cdr (assoc 70 ld))) (if (equal lc (abs lc)) (setq ooc "on") (setq ooc "off")) (if (bit_check lf (list 1)) (setq ftc "freeze") (setq ftc "thaw")) (if (or (not (equal oo ooc)) (not (equal ft ftc))) (if (equal ln cl) (if (equal ft "freeze") (prompt "\nCan't freeze current layer.") (command ft ln oo ln) ) (command ft ln oo ln) ) ) ) (command "") (command ".regenall") ) (defun c:rl() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (rename_layer) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun rename_layer(/ e ed lay nl) (prompt "\nPick entity on layer to change...") (setq e (car (entsel))) (setq ed (entget e)) (setq lay (cdr (assoc 8 ed))) (setq nl (getstring (strcat "\nChange layer " lay " to what name: "))) (layer_name_change lay nl) ) (defun c:dd() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (dimension_dot_fix) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun dimension_dot_fix(/ ss ndx de dd p1 p2 p1a p2a) (prompt "\nSet dimension nodes to zero...") (setq ss (ssget '((0 . "DIMENSION")))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq de (ssname ss ndx)) (setq dd (entget de)) (setq p1 (assoc 13 dd)) (setq p2 (assoc 14 dd)) (setq p1a (list (car p1) (cadr p1) (caddr p1) 0.0)) (setq p2a (list (car p2) (cadr p2) (caddr p2) 0.0)) (setq dd (subst p1a p1 dd)) (setq dd (subst p2a p2 dd)) (entmod dd) (entupd de) ) ) (defun c:sll() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (swap_layer_letters) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun swap_layer_letters(/ ll l n) (setq ll (list_layers)) (foreach l ll (if (or (wcmatch l "?E?-*") (wcmatch l "?D?-*") (wcmatch l "?N?-*") (wcmatch l "?G?-*")) (progn (setq n (swap_letters l)) (command ".rename" "la" l n) ) ) ) ) (defun swap_letters (str / s1 s2 s3 s4) (setq s1 (substr str 1 1)) (setq s2 (substr str 3 1)) (setq s3 (substr str 2 1)) (setq s4 (substr str 4)) (strcat s1 s2 s3 s4) ) (defun c:r3() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (r3) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun r3(/ ll l str) (setq ll (get_layers)) (foreach l ll (if (or (wcmatch l "??E-*") (wcmatch l "??D-*") (wcmatch l "??N-*") (wcmatch l "??G-*")) (progn (setq str (remove_three l)) (layer_name_change l str) ) ) ) ) (defun remove_three (str / s1 s2) (setq s1 (substr str 1 2)) (setq s2 (substr str 4)) (strcat s1 s2) ) (defun c:mz () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (command ".ucs" "") (move_to_zero) (command ".ucs" "p") (command ".undo" "end") (sysvarrestore) (prin1) ) (defun c:mza () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (command ".ucs" "") (move_to_zero_auto) (command ".ucs" "p") (command ".undo" "end") (sysvarrestore) (prin1) ) (defun move_to_zero (/ ss p1 p2) (prompt "\nSelect entities to move to zero: ") (setq ss (ssget)) (setq p1 (getpoint "\nFrom point: ")) (setq p2 (list (car p1) (cadr p1) 0.0)) (command ".move" ss "" p1 p2) ) (defun move_to_zero_auto (/ ss ndx e ed ins p2) (prompt "\nSelect ARC/TEXT/CIRCLE/SOLID/POINT/HATCH/INSERT entities to move to zero: ") (setq ss (ssget '((-4 . "")))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) (setq ins (cdr (assoc 10 ed))) (setq p2 (list (car ins) (cadr ins) 0.0)) (SETQ TESTIT (LIST INS P2)) (command ".move" (list e '(0.0 0.0 0.0)) "" ins p2) ) ) (defun c:lap () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (line_arc_to_polyline) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun line_arc_to_polyline(/ ss ndx e) (prompt "\Select lines and arcs to convert to polylines: ") (setq ss (ssget '((-4 . "")))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (command ".pedit" (list e '(0.0 0.0 0.0)) "" "") ) ) (defun c:ftol2 () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (command ".ucs" "") (face_to_line_two) (command ".ucs" "p") (command ".undo" "end") (sysvarrestore) (prin1) ) (defun face_to_line_two (/ ss ndx cl e ed p1 p2 p3 p4 lay) (prompt "\nConvert all 3DFaces to lines...") (setq ss (ssget '((0 . "3DFACE")))) (setq ndx (sslength ss)) (setq cl (getvar "CVLAYER")) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) (setq p1 (cdr (assoc 10 ed))) (setq p2 (cdr (assoc 11 ed))) (setq p3 (cdr (assoc 12 ed))) (setq p4 (cdr (assoc 13 ed))) (entdel e) (setq lay (cdr (assoc 8 ed))) (command ".layer" "set" lay "") (command ".line" p1 p2 "") (command ".line" p2 p3 "") (if (equal p3 p4) (command ".line" p3 p1 "") (progn (command ".line" p3 p4 "") (command ".line" p4 p1 "") ) ) ) (command ".layer" "set" cl "") ) (defun c:ftol () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (command ".ucs" "") (face_to_line) (command ".ucs" "p") (command ".undo" "end") (sysvarrestore) (prin1) ) (setq ZTOLER 0.75) (defun face_to_line (/ ss ndx cl e ed p1 p2 p3 p4 z1 z2 z3 z4 lay) (prompt "\nConvert non-horizontal 3DFACEs to lines...") (setq ss (ssget '((0 . "3DFACE")))) (setq ndx (sslength ss)) (setq cl (getvar "CVLAYER")) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) (setq p1 (cdr (assoc 10 ed))) (setq z1 (caddr p1)) (setq p1 (list (car p1) (cadr p1) 0.0)) (setq p2 (cdr (assoc 11 ed))) (setq z2 (caddr p2)) (setq p2 (list (car p2) (cadr p2) 0.0)) (setq p3 (cdr (assoc 12 ed))) (setq z3 (caddr p3)) (setq p3 (list (car p3) (cadr p3) 0.0)) (setq p4 (cdr (assoc 13 ed))) (setq z4 (caddr p4)) (setq p4 (list (car p4) (cadr p4) 0.0)) (entdel e) (setq level '()) ; (if (equal z1 z2 0.0001) ; (if (equal z2 z3 0.0001) ; (if (equal z3 z4 0.0001) ; (setq level 1) ; ) ; ) ; ) (if (< (abs (- z1 z2)) ZTOLER) (if (< (abs (- z2 z3)) ZTOLER) (if (< (abs (- z3 z4)) ZTOLER) (setq level 1) ) ) ) (if (not level) (progn (setq pts (two_furthest (list p1 p2 p3 p4))) (setq lay (cdr (assoc 8 ed))) (command ".layer" "set" lay "") (command ".line" (car pts) (cadr pts) "") ) ) ) (command ".layer" "set" cl "") ) (defun c:zz () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (zero_blocks) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun zero_blocks (/ ss ndx be bd ins z flags count) (prompt "\nSelect blocks to set z-coord to zero: ") (setq ss (ssget '((-4 . "")))) (setq ndx (sslength ss)) (setq count 0) (command ".ucs" "") (while (>= (setq ndx (1- ndx)) 0) (setq be (ssname ss ndx)) (setq bd (entget be)) (setq flags (cdr (assoc 70 bd))) ; (if (not (bit_check flags (list 1 4 16 32))) ;user block ; (progn ; (command ".ucs" "e" (list be '(0.0 0.0 0.0))) (setq ins (trans '(0.0 0.0 0.0) 1 0)) (setq z (caddr ins)) (if (not (equal z 0.0)) (progn (setq count (1+ count)) (command ".move" be "" (list 0.0 0.0 (- 0.0 z)) "") ) ) ; ) ; ) ) (command ".ucs" "p") (prompt (strcat "\nMoved " (itoa count) "entities to zero z coordinate.")) ) ;------------------------------------------------------------------------------ (defun c:sb () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (setq tmp (getvar "EXPERT")) (setvar "expert" 5) (scale_block) (setvar "EXPERT" tmp) (command ".undo" "end") (sysvarrestore) (prin1) ) (setq SCALE_FACTOR 1.25) (defun scale_block (/ be pt) (setq be (get_block_ename)) (prompt (strcat "\nScale factor: " (rtos SCALE_FACTOR 2))) (initget (+ 1 2 4 64) "Scale") (while (not (equal (type pt) 'LIST)) (setq pt (getpoint "\nScale. Point: ")) (if (equal pt "Scale") (set_blk_scale) ) ) (command ".scale" be "" pt SCALE_FACTOR) ) (defun set_blk_scale (/ prompt tmp) (initget (+ 2 4)) (setq prompt (strcat "\nScale factor: <" (rtos SCALE_FACTOR 2) ">: ")) (setq tmp (getreal prompt)) (if (equal (type tmp) 'REAL) (setq SCALE_FACTOR tmp) ) ) ;------------------------------------------------------------------------------ ;------------------------------------------------------------------------------ (defun c:cbn () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (setq tmp (getvar "EXPERT")) (setvar "expert" 5) (clean_block_names) (setvar "EXPERT" tmp) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun clean_block_names (/ bd) (setq bd (tblnext "BLOCK" T)) (clean_block bd) (while (setq bd (tblnext "BLOCK")) (clean_block bd) ) ) (defun clean_block (bd / oname nname) (setq oname (strcase (cdr (assoc 2 bd)))) (setq nname (name_strip oname)) (if (not (equal oname nname)) (progn (prompt (strcat "\nRenaming block " oname " to " nname "...")) (command ".rename" "block" oname nname) ) ) ) ;------------------------------------------------------------------------------ ;------------------------------------------------------------------------------ (defun c:pr () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (setq tmp (getvar "EXPERT")) (setvar "expert" 5) (polyline_renormal) (setvar "EXPERT" tmp) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun polyline_renormal (/ pe e ss olay play ep ed) (setq pe (car (entsel))); fix this (setq e (entlast)) (setq elist '()) (setq ss (ssadd)) (setq olay (getvar "CLAYER")) (setq play (cdr (assoc 8 (entget pe)))) (command ".layer" "set" play "") (command ".explode" pe) (while (setq e (entnext e)) (setq elist (cons e elist)) ) (foreach e elist (setq ed (entget e)) (if (equal (cdr (assoc 0 ed)) "ARC"); redraw so normal is o.k. (ssadd (redraw_arc e) ss) (ssadd (redraw_line e) ss) ) ) (setq ep (entlast)) (setq ep (list ep '(0.0 0.0 0.0))) (command ".pedit" ep "y" "j" ss "" "") (command ".layer" "set" olay "") ) (defun redraw_arc (ae / ad lay cen rad sa ea sp ep dir tmp) (setq ad (entget ae)) (setq cen (cdr (assoc 10 ad))) (setq rad (cdr (assoc 40 ad))) (setq dir (cdr (assoc 210 ad))) (setq sa (cdr (assoc 50 ad))) (setq ea (cdr (assoc 51 ad))) (command ".ucs" "za" "" dir) (setq sp (polar cen sa rad)) (setq ep (polar cen ea rad)) (setq sp (trans sp 1 0)) (setq ep (trans ep 1 0)) (setq cen (trans cen 1 0)) (command ".ucs" "p") (setq cen (list (car cen) (cadr cen))) (setq sp (list (car sp) (cadr sp))) (setq ep (list (car ep) (cadr ep))) (if (< (caddr dir) 0.0) (setq tmp sp sp ep ep tmp) ) (entdel ae) (command ".arc" "c" cen sp ep) (entlast) ) (defun redraw_line (le / ld p1 p2 dir) (setq ld (entget le)) (setq p1 (cdr (assoc 10 ld))) (setq p2 (cdr (assoc 11 ld))) (setq dir (cdr (assoc 210 ld))) (command ".ucs" "za" "" dir) ; (setq p1 (trans p1 1 0)) ; (setq p2 (trans p2 1 0)) (command ".ucs" "p") (setq p1 (list (car p1) (cadr p1))) (setq p2 (list (car p2) (cadr p2))) (entdel le) (command ".line" p1 p2 "") (entlast) ) ;------------------------------------------------------------------------------ (defun c:pflat2 () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (setvar "expert" 1) (polyline_flatten_two) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun polyline_flatten_two (/ ss ndx pe pd lay vlist m clay c cflag) (prompt "\nSelect polylines to flatten: ") (setq ss (ssget (list (cons 0 "LWPOLYLINE")))) ;Update for pre-14 (setq ndx (sslength ss)) (setq clay (getvar "CLAYER")) (while (>= (setq ndx (1- ndx)) 0) (setq pe (ssname ss ndx)) (setq pd (entget pe)) (setq nd '()) (foreach m pd (if (equal (car m) 38) ; vertex (setq m (cons 38 0.0)) ) (setq nd (append nd (list m))) ) (entmod nd) (entupd pe) ; (setq lay (cdr (assoc 8 pd))) ; (setq c (cdr (assoc 70 pd))) ; (if (not (bit_check c (list 1)));polyline is not closed ; (setq cflag "unclosed") ; (setq cflag "closed") ; ) ; (command ".layer" "set" lay "") ; (setq vlist '()) ; (foreach m pd ; (if (equal (car m) 10) ; vertex ; (setq vlist (append vlist (list (list (cadr m) (caddr m) 0.0)))) ; ) ; ) ; (redraw_pline vlist cflag) ) ; (command ".layer" "set" clay "") ) (defun redraw_pline (plst close_flag / p) (command ".pline") (foreach p plst (command p) ) (if (equal close_flag "closed") (command "c") (command "") ) ) ;------------------------------------------------------------------------------ (setq PTEXT_HEIGHT (/ 3.0 32.0)) ;Plotted height (setq DRAWING_SCALE 1.0) (defun c:lead () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (setvar "expert" 1) (draw_leader) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun draw_leader (/ st p1 p2 pa wd dir off e ss ed ins e1 ed1 ins1) (prompt (strcat "\nPlotted text height: " (rtos PTEXT_HEIGHT) " Drawing scale: " (rtos DRAWING_SCALE 2))) (setq st (getvar "TEXTSTYLE")) (setq st (tblsearch "STYLE" st)) (setq st (cdr (assoc 40 st))) (while (not (equal (type p1) 'LIST)) (setq p1 "") (initget (+ 1 2 4 64) "Options") (setq p1 (getpoint "\nptions. First point: ")) (if (equal p1 "Options") (set_options) ) ) (initget (+ 1 2 4)) (setq p2 (getpoint p1 "\nNext point: ")) (setq pt (arrow_pt p1 p2)) (setq wd (/ (* PTEXT_HEIGHT DRAWING_SCALE) 2.25)) (command ".pline" p1 "w" 0.0 wd pt "w" 0.0 0.0 p2) (setvar "ORTHOMODE" 1) (while (not (equal p1 p2)) (setq pt p2) (command pause) (setq p2 p1 p1 (getvar "LASTPOINT")) ) (setq dir (- (car p2) (car pt))) ;Direction of last line segment (if (< dir 0.0) (progn (setq just "MR") (setq off (list (/ PTEXT_HEIGHT -2.0) 0.0 0.0)) ) (progn (setq just "ML") (setq off (list (/ PTEXT_HEIGHT 2.0) 0.0 0.0)) ) ) (setq off (v_scale off DRAWING_SCALE)) (setq p2 (mapcar '+ off p2)) (setq e (entlast)) (if (equal st 0.0); text style height defined to be zero (command ".dtext" "J" just p2 (* PTEXT_HEIGHT DRAWING_SCALE) "0") (command ".dtext" "J" just p2 "0") ) (setq p2 (mapcar '- p2 (list 0.0 (/ (* PTEXT_HEIGHT DRAWING_SCALE) 2.0) 0.0))) ; (setq ss (ssadd)) ; (setq e1 (entnext e)) ; (setq ed1 (entget e1)) ; (setq ins1 (trans (cdr (assoc 10 ed1)) 0 1)) ; (while (setq e (entnext e)) ; (ssadd e ss) ; ) ; (setq e (entlast)) ; (setq ed (entget e)) ; (setq ins (trans (cdr (assoc 10 ed)) 0 1)) ; (command ".move" ss "" ins ins1) (if (equal just "MR") (if (equal (cdr (assoc 0 (entget (entlast)))) "TEXT") (reset_text p2) ) ) (if (not (equal st 0.0)) (prompt "\nCURRENT TEXT STYLE HAS FIXED HEIGHT.") ) ) (defun reset_text (p1 / e1 ins1 e2 p2 ins2 ss) ; (setq e1 (entnext e)) ; (setq ins1 (cdr (assoc 10 (entget e1)))) ; (setq p1 (trans p1 0 1)) (setq e2 (entlast)) (setq ins2 (cdr (assoc 10 (entget e2)))) (setq p2 (trans ins2 0 1)) (setq p1 (list 0.0 (cadr p1))) (setq p2 (list 0.0 (cadr p2))) (setq ss (ssadd)) (while (setq e (entnext e)) (ssadd e ss) ) (command ".move" ss "" p2 p1) (setq ss '()) ) (defun arrow_pt (p1 p2 / d v) (setq d (* PTEXT_HEIGHT DRAWING_SCALE)) (setq v (v_scale (normal_vec (mapcar '- p2 p1)) d)) (mapcar '+ p1 v) ) (defun set_options (/ p tmp) (initget (+ 2 4)) (setq p (strcat "\nDrawing scale factor: <" (rtos DRAWING_SCALE 2) ">: ")) (setq tmp (getreal p)) (if (equal (type tmp) 'REAL) (setq DRAWING_SCALE tmp) ) (initget (+ 2 4 64)) (setq p (strcat "\nPlotted text height: <" (rtos PTEXT_HEIGHT) ">: ")) (setq tmp (getdist p)) (if (equal (type tmp) 'REAL) (setq PTEXT_HEIGHT tmp) ) ) ;------------------------------------------------------------------------------ (defun c:bi () (sysvarinit '("cmdecho" "blipmode" "orthomode")) (command ".undo" "group") (setvar "expert" 1) (block_insert) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun block_insert(/ bname p1 p2 scl ang) (setq bname (get_bname)) (setq p1 (getpoint "\nInsertion point: ")) (setq p2 (getpoint p1 "\nScale and direction point: ")) (setq scl (distance p1 p2)) (setq ang (angtos (angle p1 p2))) (command ".insert" bname p1 scl "" ang) ) (setq LAST_BNAME "") (defun get_bname (/ blk) (setq blk (getstring (strcat "\nBlock name <" LAST_BNAME ">: "))) (if (equal blk "") (setq blk LAST_BNAME)) (while ( and (not (tblsearch "BLOCK" blk)) (not (equal blk ""))) (progn (prompt (strcat "\nBlock " (strcase blk) " not defined, try again...")) (setq blk (getstring (strcat "\nBlock name <" LAST_BNAME ">: "))) ) ) (if blk (progn (strcase blk) (setq LAST_BNAME blk) ) nil ) ) (defun c:pc () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (setq tmp (getvar "expert")) (setvar "expert" 1) (polyline_connect) (command ".undo" "end") (setvar "expert" tmp) (sysvarrestore) (prin1) ) (defun polyline_connect (/ e1 e ed lay ss t c) (prompt "\nSelect line to connect to...") (setq e1 (entsel)) (setq e (car e1)) (setq ed (entget e)) (setq lay (cdr (assoc 8 ed))) (setq t (cdr (assoc 0 ed))) (prompt "\nSelect entities to connect...") (setq ss (ssget (list (cons 8 lay)))) (if (equal t "LINE") (command ".pedit" e1 "y" "join" ss "" "") (command ".pedit" e1 "join" ss "" "") ) (setq e (entlast)) (setq ed (entget e)) (setq e (list e '(0.0 0.0 0.0))) (setq c (cdr (assoc 70 ed))) (if (not (bit_check c (list 1)));polyline is not closed (command ".pedit" e "close" "") ) ) (defun c:yy (/ tmp) (save_state_layers 'LAYER_STATE) (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (setq tmp (getvar "expert")) (setvar "expert" 1) (command ".undo" "group") (layer_isolate) (command ".undo" "end") (setvar "expert" tmp) (sysvarrestore) (prin1) ) ;(defun layer_isolate (/ e ed lay) ; (setq e (car (entsel "\nPick entity on layer to isolate: "))) ; (setq ed (entget e)) ; (setq lay (cdr (assoc 8 ed))) ; (command ".layer" "off" "*" "on" lay "") ;) (defun layer_isolate (/ ll data l) (prompt "\nSelect entities on layers you would like to isolate: ") (setq ll '()) (while (setq data (find_entity_data)) (setq l (cadddr data)) (if (not (member l ll)) (progn (setq ll (cons l ll)) (prompt (strcat "\nAdded layer " (strcase l))) ) (progn (setq ll (remove l ll)) (prompt (strcat "\nRemoved layer " (strcase l))) ) ) ) (if ll (progn (command ".layer" "off" "*") (foreach l ll (command "on" l) ) (command "") ) ) ) (defun c:g () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (glue) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun glue(/ ss lay) (prompt "\nSelect lines to glue: ") (setq ss (ssget '((0 . "LINE")))) (setq e1 (ssname ss 0)) (setq ed (entget e1)) (setq lay (cdr (assoc 8 ed))) ; (setq lay (getvar "CLAYER")) (reduce_lines ss lay) ) (defun c:ezl () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (erase_zero_lengths) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun erase_zero_lengths (/ dis ss ndx e ed p1 p2 len) (prompt "\Select lines: ") (setq ss (ssget '((0 . "LINE")))) (setq dis (getdist "\nErase lines less than length: ")) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) (setq p1 (cdr (assoc 10 ed))) (setq p2 (cdr (assoc 11 ed))) (setq len (vector_length (mapcar '- p1 p2))) (if (not (> len dis)) (entdel e) ) ) ) (defun c:le () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (line_end) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun line_end () (prompt "\nPick endpoint: ") (command ".line" "end" PAUSE) ) (defun c:lm () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (line_mid) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun line_mid () (prompt "\nPick midpoint: ") (command ".line" "mid" PAUSE) ) (defun c:lc () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (line_cen) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun line_cen () (prompt "\nPick center point: ") (command ".line" "cen" PAUSE) ) (defun c:ln () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (line_ins) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun line_ins () (prompt "\nPick insertion point: ") (command ".line" "ins" PAUSE) ) (defun c:lt () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (line_int) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun line_int () (prompt "\nPick intersection: ") (command ".line" "int" PAUSE) ) ;------------------------------------------------------------------------------ (setq FF_LAYER "0") (setq FF_WIDTH 0.1) (setq FF_LENGTH 0.1) (defun c:ff () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (ff) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun ff (/ num fix_layer ss len le related_ss ndx ang) (setq num 1) (setq fix_layer (get_layer (strcat "\nLayer to fix <" FF_LAYER ">: "))) (if (or (equal fix_layer nil) (equal fix_layer "")) (setq fix_layer FF_LAYER)) (setq fix_layer (strcase fix_layer)) (setq FF_LAYER fix_layer) (setq ss (ssget (list (cons 0 "LINE") (cons 8 fix_layer)))) (if (not ss) (exit)) (setq len (sslength ss)) (while (> (sslength ss) 0) (setq le (ssname ss 0)) (setq ang (angle (cdr (assoc 10 (entget le))) (cdr (assoc 11 (entget le))))) (setq related_ss (ssadd le)) (setq ndx (get_related le related_ss ang)) (while (>= (setq ndx (1- ndx)) 0) (setq le (ssname related_ss ndx)) (ssdel le ss) ) (if (> (sslength related_ss) 1) (progn (reduce_lines related_ss fix_layer) (prompt (strcat "\nFixed line number " (itoa num) "...")) (setq num (1+ num)) ) ) (setq len (sslength ss)) (if (equal (rem len 50) 0) (prompt (strcat "\n" (itoa len) " lines left...")) ) ) ) (defun get_related (le related_ss ang / ld lay e1 e2 sel_pts ls ndx e) (setq ld (entget le) lay (cdr (assoc 8 ld)) e1 (cdr (assoc 10 ld)) e1 (list (car e1) (cadr e1)) e2 (cdr (assoc 11 ld)) e2 (list (car e2) (cadr e2)) ) (setq sel_pts (make_buf_fence e1 e2 FF_WIDTH FF_LENGTH)) (setq ls (ssget "cp" sel_pts (list '(0 . "LINE") (cons 8 lay)))) (if ls (if (> (sslength ls) 0) (progn (ssdel le ls) (setq ls (get_parallel ang ls)) (if ls (progn (setq ndx (sslength ls)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ls ndx)) (if (not (ssmemb e related_ss)) (progn (ssadd e related_ss) (get_related e related_ss ang) ) ) ) )) ))) (setq ls nil) (sslength related_ss) ) (defun make_buf_fence (p1 p2 w l / v v1 v2 pt1 pt2 pt3 pt4) (setq p1 (extend_vec p2 p1 l)) (setq p2 (extend_vec p1 p2 l)) (setq v (mapcar '- p2 p1)) (setq v (v_scale v (/ 1.0 (vector_length v)))) (setq v (v_scale v w)) (setq v1 (vec_z_rotate v (/ PI 2.0))) (setq v2 (vec_z_rotate v1 PI)) (setq pt1 (mapcar '+ p1 v1)) (setq pt2 (mapcar '+ p1 v2)) (setq pt3 (mapcar '+ p2 v2)) (setq pt4 (mapcar '+ p2 v1)) (list pt1 pt2 pt3 pt4) ) (defun extend_vec (pb p2 d / vtemp vd1 vd2 vs nvec ret) (setq vtemp (mapcar '- p2 pb)) (setq vd1 (vector_length vtemp)) (if (> vd1 0.0) (progn (setq vd2 (+ vd1 d)) (setq vs (/ vd2 vd1)) (setq nvec (v_scale vtemp vs)) (setq ret (mapcar '+ nvec pb)) ) (setq ret p2) ) ret ) (defun get_parallel (ang ls / ndx return_ss ee ed e1 e2 ta) (setq ndx (sslength ls)) (setq return_ss (ssadd)) (while (>= (setq ndx (1- ndx)) 0) (setq ee (ssname ls ndx)) (setq ed (entget ee)) (setq e1 (cdr (assoc 10 ed))) (setq e2 (cdr (assoc 11 ed))) (setq ta (angle e1 e2)) (if (parallel ang ta 0.01) (ssadd ee return_ss) ) ) return_ss ) (defun reduce_lines (ss lay / ndx ends le ld p1 p2) (setq ends nil) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq le (ssname ss ndx)) (setq ld (entget le)) (setq p1 (cdr (assoc 10 ld))) (setq p2 (cdr (assoc 11 ld))) (setq ends (cons p1 ends)) (setq ends (cons p2 ends)) (entdel le) ) (setq ends (two_furthest ends)) (setq ld (list '(0 . "LINE") (cons 8 lay) (cons 10 (car ends)) (cons 11 (cadr ends)))) (entmake ld) ) (defun two_furthest (pt_list / pt1 pt2 dist pt d1 d2) (setq pt1 (car pt_list)) (setq pt_list (cdr pt_list)) (setq pt2 (car pt_list)) (setq pt_list (cdr pt_list)) (setq dist (distance pt1 pt2)) (foreach pt pt_list (setq d1 (distance pt pt1)) (setq d2 (distance pt pt2)) (if (and (> d1 dist) (> d1 d2)) (setq pt2 pt)) (if (and (> d2 dist) (> d2 d1)) (setq pt1 pt)) (setq dist (distance pt1 pt2)) ) (list pt1 pt2) ) ;------------------------------------------------------------------------------ ;----------------------------------------------------------------BEGIN C:TI---- (defun c:ti() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (tilemode_flip) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun tilemode_flip (/ tm) (setq tm (getvar "TILEMODE")) (setq tm (* (- tm 1) -1)) (command ".tilemode" tm) ) ;------------------------------------------------------------------END C:TI---- ;----------------------------------------------------------------BEGIN C:ZW---- (defun c:zw() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (zoom_window) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun zoom_window (/ p1 p2) (setq p1 (getpoint "\nFirst Point: ")) (setq p2 (getcorner p1 "\nSecond Point: ")) (command ".zoom" "window" p1 p2) ) ;------------------------------------------------------------------END C:ZW---- ;----------------------------------------------------------------BEGIN C:ZD---- (defun c:zd() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (zoom_dynamic) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun zoom_dynamic (/ p1 p2) (setq p1 '() p2 '()) (setq p1 (getvar "LASTPOINT")) (command ".zoom" "dynamic") (while (not (equal p1 p2)) (command pause) (setq p2 p1 p1 (getvar "LASTPOINT")) ) (command) ) ;------------------------------------------------------------------END C:ZD---- ;----------------------------------------------------------------BEGIN C:ZP---- (defun c:zp() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (zoom_previous) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun zoom_previous () (command ".zoom" "previous") ) ;------------------------------------------------------------------END C:ZP---- ;----------------------------------------------------------------BEGIN C:ZE---- (defun c:ze() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (zoom_extents) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun zoom_extents () (command ".zoom" "e") ) ;------------------------------------------------------------------END C:ZE---- ;----------------------------------------------------------------BEGIN C:ZO---- (defun c:zo() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (zoom_out) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun zoom_out (/ cp) (setq cp (getpoint "\nCenter point: ")) (command ".zoom" "c" cp "0.5x") ) ;------------------------------------------------------------------END C:ZO---- ;----------------------------------------------------------------BEGIN C:ZI---- (defun c:zi() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (zoom_in) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun zoom_in (/ cp) (setq cp (getpoint "\nCenter point: ")) (command ".zoom" "c" cp "2x") ) ;------------------------------------------------------------------END C:ZI---- ;---------------------------------------------------------------BEGIN C:CTL---- (defun c:ctl() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (copy_to_layer) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun copy_to_layer (/ ss en ed ly ndx) (prompt "\nCopy To Layer") (setq ss (ssget)) (prompt "\nPick entity on new layer: ") (setq en (car (entsel))) (setq ed (entget en)) (setq ly (cdr (assoc 8 ed))) (setq ndx (sslength ss)) (command ".copy" ss "" "0,0" "") (command ".chprop" "p" "" "layer" ly "") ; (while (>= (setq ndx (1- ndx)) 0) ; (setq en (ssname ss ndx)) ; (setq ed (entget en)) ; (setq ed (set_code ed 8 ly)) ; (entmake ed) ; ) ) ;-----------------------------------------------------------------END C:CTL---- ;--------------------------------------------------------------BEGIN C:TWID---- (defun c:twid() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (text_width) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun text_width() (prompt "\nSelect text entities to recreate...") (setq ss (ssget '((0 . "TEXT")))) (setq nw (getdist "\nNew text width: ")) (text_width_change ss nw) ) (defun text_width_change(ss nw / ndx e ed xsc newed) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) (setq xsc (assoc 41 ed)) ; (if xsc ; (setq newed (remove xsc ed)) ; (setq newed ed) ; ) (if xsc (setq newed (subst (cons 41 nw) xsc ed)) (setq newed (cons (cons 41 nw) ed)) ) (entdel e) (entmake newed) ) ) ;----------------------------------------------------------------END C:TWID---- ;----------------------------------------------------------------BEGIN C:CS---- (defun c:cs() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (color_select) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun color_select(/ col) (setq col (getint "\nColor Number to select: ")) (ssget "x" (list (cons 62 col))) (prompt (strcat "\nAll entities assigned color " (itoa col) " added to \"previous\" selection.")) ) ;------------------------------------------------------------------END C:CS---- ;---------------------------------------------------------------BEGIN C:LCS---- (defun c:lcs() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (lay_color_select) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun lay_color_select(/ col laysel) (setq col (getint "\nColor Number to select: ")) (setq laysel (laysel_list_by_color col)) (ssget "x" laysel) (prompt (strcat "\nAll entities on layers with color " (itoa col) " added to \"previous\" selection.")) ) (defun laysel_list_by_color (col / layer_data sel name c) (setq layer_data (tblnext "LAYER" T)) (setq sel '((-4 . "OR>"))) (while layer_data (setq name (cdr (assoc 2 layer_data))) (setq c (cdr (assoc 62 layer_data))) (if (equal c col) (setq sel (cons (cons 8 name) sel)) ) (setq layer_data (tblnext "LAYER")) ) (setq sel (cons '(-4 . "")))) (setq ndx (sslength ss)) (setq cl (getvar "CLAYER")) (while (>= (setq ndx (1- ndx)) 0) (setq pe (ssname ss ndx)) (setq pd (entget pe)) (setq pf (cdr (assoc 70 pd))) (setq closed (bit_check pf '(1))) ;T if polyline is closed. (if (not closed) (if (not (too_open pe limit)) (progn (setq pl (make_vertex_pt_list pe)) (setq pl (cdr pl)) (if (> (length pl) 1) (progn (setq lay (cdr (assoc 8 pd))) (command ".layer" "set" lay "") (entdel pe) (draw_cpline pl) (command ".layer" "set" cl "") ) (prompt "\nDidn't close short single-segment polyline...") ) ) ) ) ) ) (defun too_open (pe limit / ends) (setq ends (get_pl_ends pe)) (> (distance (car ends) (cadr ends)) limit) ) (defun get_pl_ends (pe / ends e1 e2 ed p1 p2 pd pltype) (setq ends '()) (setq pltype (cdr (assoc 0 (entget pe)))) (if (equal pltype "POLYLINE") (progn (setq e1 (entnext pe)) (setq e2 (entnext e1)) (setq ed (entget e2)) (while (not (equal (cdr (assoc 0 ed)) "SEQEND")) (setq ep ed) (setq e2 (entnext e2)) (setq ed (entget e2)) ) (setq p1 (cdr (assoc 10 (entget e1)))) (setq p2 (cdr (assoc 10 ep))) (setq ends (list p1 p2)) ) (progn (setq pd (entget pe)) (setq p1 (cdr (assoc 10 pd))) (setq pd (reverse pd)) (setq p2 (cdr (assoc 10 pd))) (setq ends (list p1 p2)) ) ) ends ) ;-------------------------------------------------------------END C:PCLOSE---- ;----------------------------------------------------------------BEGIN C:EE---- (defun c:ee () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (ee) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun ee (/ pt1 pt2 lay_filt lay wa_ss pl_ss dis_dir pl_ss ssfilt) (setq extrae '()) (prompt "\nSelect wall...") (setq pt1 (getpoint "\nPoint one: ")) (setq pt2 (getpoint pt1 "\nPoint two: ")) (setq ssfilt (list '(-4 . ""))) (setq pl_ss (ssget "f" (list pt1 pt2) ssfilt)) ; (setq pl_ss (ssget "f" (list pt1 pt2) (list (cons 0 PL_NAME)))) (setq wa_ss (ssget "f" (list pt1 pt2) '((0 . "LINE")))) (if (> (sslength wa_ss) 2) (progn (prompt "\nMust select ONE or TWO wall lines") (exit) ) ) (if (equal (sslength wa_ss) 1) (progn (command ".copy" wa_ss "" "0,0" "") (setq extrae (entlast)) (setq wa_ss (ssadd extrae wa_ss)) ) ) (setq wall1 (ssname wa_ss 0) wall2 (ssname wa_ss 1)) (if (not (parallel_lines? wall1 wall2)) (progn (prompt "\nMust select parallel wall lines.") (exit) ) ) (move_center pl_ss wall1 wall2 pt1 pt2) (if extrae (entdel extrae)) ) (defun move_center (pl_ss line1 line2 pt1 pt2 / vcl ndx pl vl np1 np2 vp1 vp2 vd1 vd2) (setq vcl (make_virtual_center_line wall1 wall2) ndx (sslength pl_ss)) (while (>= (setq ndx (1- ndx)) 0) (setq pl (ssname pl_ss ndx)) (if (equal (cdr (assoc 0 (entget pl))) "LWPOLYLINE") (progn (lwpoly_to_poly pl) (setq pl (entlast)) ) ) (setq vl (get_seg pl pt1 pt2)) (if (> (length vl) 2) (progn (setq np1 (inters (car vcl) (cadr vcl) (cdar vl) (cdadr vl) '()) np2 (inters (car vcl) (cadr vcl) (cdaddr vl) (cdr (cadddr vl)) '()) vp1 (caadr vl) vp2 (caaddr vl) vd1 (entget vp1) vd2 (entget vp2) vd1 (subst (cons 10 np1) (assoc 10 vd1) vd1) vd2 (subst (cons 10 np2) (assoc 10 vd2) vd2)) (if (equal (length np1) 2) (setq np1 (append np1 (list 0.0)))) (if (equal (length np2) 2) (setq np2 (append np2 (list 0.0)))) (entmod vd1) (entmod vd2) (entupd pl) ) (prompt "\nPolyline must have more than two vertices.") ) ) ) (defun parallel_lines? (le1 le2 / ld1 ld2 ang1 ang2) (setq ld1 (entget le1) ld2 (entget le2) ang1 (angle (cdr (assoc 10 ld1)) (cdr (assoc 11 ld1))) ang2 (angle (cdr (assoc 10 ld2)) (cdr (assoc 11 ld2)))) (parallel ang1 ang2 0.1) ) (defun parallel (ang1 ang2 tolerance / bang) ; OPPOSITE ANGLES ALSO PARALLEL. (setq ang1 (rem ang1 PI) ang2 (rem ang2 PI) bang (abs (- ang1 ang2)) bang (min bang (- PI bang)) ) (<= bang tolerance) ) (defun make_simple_center (l1e1 l1e2 l2e1 l2e2) (setq c1 (get_midpoint l1e1 l2e1) c2 (get_midpoint l1e2 l2e2) c3 (get_midpoint l1e1 l2e2) c4 (get_midpoint l1e2 l2e1)) (if (> (distance c1 c2) (distance c3 c4)) (list c1 c2) (list c3 c4) ) ) (defun make_virtual_center_line (le1 le2 / ld1 ld2 l1e1 l1e2 l2e1 l2e2 c1 c2 c3 c4 t1 t2 v_line) (setq ld1 (entget le1) ld2 (entget le2) l1e1 (cdr (assoc 10 ld1)) l1e2 (cdr (assoc 11 ld1)) l2e1 (cdr (assoc 10 ld2)) l2e2 (cdr (assoc 11 ld2)) c1 (get_midpoint l1e1 l2e1) c2 (get_midpoint l1e2 l2e2) c3 (get_midpoint l1e1 l2e2) c4 (get_midpoint l1e2 l2e1)) (if (> (distance c1 c2) (distance c3 c4)) (progn (setq t1 (get_projection_point c1 c2 l1e1) t2 (get_projection_point c1 c2 l2e1)) (if (> (distance t1 c2) (distance t2 c2)) (setq c1 t1) (setq c1 t2) ) (setq t1 (get_projection_point c1 c2 l1e2) t2 (get_projection_point c1 c2 l2e2)) (if (> (distance t1 c1) (distance t2 c1)) (setq c2 t1) (setq c2 t2) ) (setq v_line (list c1 c2)) ) (progn (setq t1 (get_projection_point c3 c4 l1e1) t2 (get_projection_point c3 c4 l2e2)) (if (> (distance t1 c4) (distance t2 c4)) (setq c3 t1) (setq c3 t2) ) (setq t1 (get_projection_point c3 c4 l1e2) t2 (get_projection_point c3 c4 l2e1)) (if (> (distance t1 c3) (distance t2 c3)) (setq c4 t1) (setq c4 t2) ) (setq v_line (list c3 c4)) ) ) v_line ) ;USE MAKE_VERTEXT_PT_LIST (defun make_vertex_list (pl_ent / v_list e ed) (setq ed (entget pl_ent)) (setq et (cdr (assoc 0 ed))) (setq v_list nil) (if (equal et "POLYLINE") (progn (setq e pl_ent) (while (/= (cdr (assoc 0 (setq ed (entget (setq e (entnext e)))))) "SEQEND") (if (= (cdr (assoc 0 ed)) "VERTEX") (setq v_list (append v_list (list (cons e (cdr (assoc 10 ed)))))) ) ) ) (progn (prin1); ) ) v_list ) (defun get_projection_point (e1 e2 p / bp op v1 v2) ;; E1 & E2 POINTS DEFINE LINE P PROJECTED ONTO. (if (< (distance e1 p) (distance e2 p)) (setq bp e1 op e2) (setq bp e2 op e1) ) ;; TO GET LEAST ACUTE ANGLE (setq v1 (mapcar '- op bp) v2 (mapcar '- p bp) p (v_scale v1 (/ (dot_product v1 v2) (dot_product v1 v1))) p (mapcar '+ bp p)) p ) ;; Unless the polyline only has two points, GET_SEG will return four points. ;; The second and third point define the intersected segment. The first ;; point can be used to indicate the direction to displace the second ;; point. The fourth point serves the same function for the third point. ;; (defun get_seg (pl_ent pt1 pt2 / vpt_list sub_list i ndx int) (setq vpt_list (make_vertex_list pl_ent) sub_list nil) (if (equal (length vpt_list) 2) vpt_list ;; CHECK FOR LENGTH 2 IN CALLING FUNCTION... (progn (setq i (length vpt_list) ndx 1 vpt_list (cons (last vpt_list) vpt_list) vpt_list (append vpt_list (list (cadr vpt_list) (caddr vpt_list)))) (while (and (equal sub_list nil) (<= ndx i)) (setq sub_list (list (car vpt_list) (cadr vpt_list) (caddr vpt_list) (cadddr vpt_list))) (setq int (inters (cdadr sub_list) (cdaddr sub_list) pt1 pt2)) (if (not int) (setq sub_list nil) ) (setq ndx (1+ ndx) vpt_list (cdr vpt_list)) ) ) ) sub_list ) (defun v_scale (v scale / ret item) (setq ret nil) (foreach item v (setq item (* item scale)) (setq ret (append ret (list item))) ) ret ) (defun dot_product (v1 v2) ;; Equals 0 if vectors are perpendicular. (apply '+ (mapcar '* v1 v2)) ) (defun vector_length (v) (sqrt (dot_product v v)) ) (defun normal_vec (v) (v_scale v (/ 1.0 (vector_length v))) ) (defun vector_reverse (v / x) (mapcar '(lambda (x) (* -1 x)) v) ) ;------------------------------------------------------------------END C:EE---- ;----------------------------------------------------------------begin C:SF---- ; This function will move the endpoints of lines and the vertices of ; polylines to the nearest snap point. The snap grid dimensions will ; be specified by the user. (setq ACCURACY 0.0001) (defun vertex_pos (vert_data) (cdr (assoc 10 vert_data)) ) ; Round a number to the significant digit specified by 'dec'. (defun round (num dec / s i r) (if (equal (type dec) 'INT) (setq num (/ num (float dec))) (setq num (/ num dec)) ) (if (equal (abs num) num) (setq s 1) (setq s -1) ) (setq num (abs num)) (setq i (fix num)) (if (= i 0) (setq r num) (setq r (rem num i)) ) (if (> r 0.5) (setq num (+ i 1)) (setq num i) ) (* (* num dec) s) ) (defun orient_ucs_to_snap (/ b ang) (setq b (getvar "snapbase")) (setq ang (getvar "snapang")) (setq ang (angtos ang)) (command ".ucs" "world") (command ".ucs" "origin" b) (command ".ucs" "z" ang) ) ; This assumes ucs shares position and orientation of snap grid. (defun near_snap (pt / x y x_space y_space xp yp) (setq pt (trans pt 0 1)) (setq x (car pt)) (setq y (cadr pt)) (setq x_space (car (getvar "snapunit"))) (setq y_space (cadr (getvar "snapunit"))) (setq xp (* (round (/ x x_space) 1) x_space)) (setq xp (round xp ACCURACY)) (setq yp (* (round (/ y y_space) 1) y_space)) (setq yp (round yp ACCURACY)) (list xp yp) ) (defun snap_fix_line (line_data / p1 p2 e) (setq p1 (near_snap (cdr (assoc 10 line_data)))) (setq p2 (near_snap (cdr (assoc 11 line_data)))) (setq e (cdr (assoc -1 line_data))) (command ".change" e "" p1) (command ".change" e "" p2) ) (defun snap_fix_polyline (pline_data / e p vp_list v_list ed vp v) (setq e (cdr (assoc -1 pline_data))) (setq p (cdr pline_data)) (setq vp_list '()) (setq v_list '()) (while (not (equal (cdr (assoc 0 (setq ed (entget (setq e (entnext e)))))) "SEQEND")) (setq vp (cons 10 (trans (near_snap (vertex_pos ed)) 1 0))) (if (not (member vp vp_list)) (progn (setq vp_list (cons vp vp_list)) (setq v (subst vp (assoc 10 ed) ed) ) (setq v_list (append v_list (list v))) ) ) ) (if (not (equal (length vp_list) 1)) (progn (entdel (cdr (assoc -1 pline_data))) (entmake p) (foreach v v_list (entmake v)) (entmake '((0 . "SEQEND"))) ) (entdel (cdr (assoc -1 pline_data))) ) ) (defun snap-fix (/ ss ndx ed) (prompt "\nPick lines and polylines to fix: ") (setq ss (ssget)) (setq ss (ssget "p" (list '(-4 . ""))) ) (orient_ucs_to_snap) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (prompt (strcat "\nFixing number " (itoa (1+ ndx)) "...")) (setq ed (entget (ssname ss ndx))) (if (equal (cdr (assoc 0 ed)) "LINE") (snap_fix_line ed) (snap_fix_polyline ed) ) (entupd (cdr (assoc -1 ed))) ) ) (defun c:sf (/ tmp1 tmp2) (command ".undo" "group") (setq tmp1 (getvar "expert")) (setq tmp2 (getvar "orthomode")) (setvar "expert" 5) (setvar "orthomode" 0) (command ".ucs" "save" "snaptemp") (prompt "\nUses snap grid as it exists relative to WORLD coordinate system.") (snap-fix) (command ".ucs" "restore" "snaptemp") (setvar "expert" tmp1) (setvar "orthomode" tmp2) (command ".undo" "end") (prin1) ) ;------------------------------------------------------------------end C:SF---- ;-------------------------------------------------------------begin C:LEDIT---- (defun c:ledit () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (layer_edit) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun layer_edit(/ ll pre suf ln nln) (setq ll (get_layers)) (setq pre (strcase (getstring "\nAdd prefix: "))) (setq suf (strcase (getstring "\nAdd suffix: "))) (setq preout (strcase (getstring "\nRemove prefix: "))) (setq sufout (strcase (getstring "\nRemove suffix: "))) (foreach ln ll (setq nln (string_remove ln preout sufout)) (setq nln (strcat pre nln suf)) (if (not (equal ln nln)) (layer_name_change ln nln) ) ) ) (defun string_remove (s preout sufout / prelen sufpos pre suf) (setq s (strcase s)) (setq preout (strcase preout)) (setq sufout (strcase sufout)) (setq prelen (strlen preout)) (setq sufpos (1+ (- (strlen s) (strlen sufout)))) (setq pre (substr s 1 prelen)) (if (> sufpos 0) (setq suf (substr s sufpos)) (setq suf "") ) (if (and (equal pre preout) (> (strlen s) (strlen pre))) (setq s (substr s (1+ prelen))) ) (if (and (equal suf sufout) (> (strlen s) (strlen suf))) (setq s (substr s 1 (1- sufpos))) ) s ) (defun show_strings (slist) (prompt "\n") (while (> (length slist) 1) (prompt (strcat (car slist) ", ")) (setq slist (cdr slist)) ) (prompt (car slist)) ) (defun sort_strings (string_list) (shell_sort string_list '(lambda (x y) (> (strcase x) (strcase y)))) ) (defun merge_sort (lst fun / len tmp) (setq len (length lst)) (if (> len 2) (progn (setq tmp (split_list lst)) (merge (merge_sort (car tmp) fun) (merge_sort (cadr tmp) fun)) ) (if (equal len 1) lst (if (apply fun (car lst) (cadr lst)) lst (reverse lst) ) ) ) ) (defun split_list (lst) (setq len (length lst)) (setq mid (/ len 2)) (setq piv (nth lst mid)) ; this is gonna be slow.... what to do, what to do.... ) ; Return sorted list by combining lst1 & lst2 ; Assume lst1 and lst2 are already sorted. (defun merge (lst1 lst2 fun / lst) (setq lst '()) (while (and lst1 lst2) (if (apply fun (car lst1) (car lst2)) ; lst1 element less then lst2 (setq lst (cons (car lst1) lst) lst1 (cdr lst1)) (setq lst (cons (car lst2) lst) lst2 (cdr lst2)) ) ) (if lst1 (append (reverse lst1) lst) (append (reverse lst2) lst) ) ) (defun shell_sort (lst fun / n gap i j tmp) (setq n (length lst) gap (/ n 2) ) (while (> gap 0) (setq i gap) (while (< i n) (setq j (- i gap)) (while (>= j 0) (if (apply fun (list (nth j lst) (nth (+ j gap) lst))) (setq tmp (nth j lst) lst (replace_nth lst j (nth (+ j gap) lst)) lst (replace_nth lst (+ j gap) tmp) ) ) (setq j (- j gap)) ) (setq i (1+ i)) ) (setq gap (/ gap 2)) ) lst ) (defun replace_nth (lst n item / i start_list len) (setq i 0 start_list '() len (length lst) ) (if (< n len) (progn (while (< i n) (setq start_list (append start_list (list (car lst))) lst (cdr lst) i (1+ i) ) ) (setq lst (cons item (cdr lst)) lst (append start_list lst) ) ) ) lst ) ;---------------------------------------------------------------end C:LEDIT---- ;--------------------------------------------------------------begin C:BREP---- (defun c:brep () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (block_replace) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun block_replace (/ bn ss nb ndx be bd) (prompt "\nSelect blocks to replace...") (setq ss (ssget (list '(0 . "INSERT")))) (setq nb (getstring "\nNew block name: ")) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq be (ssname ss ndx)) (setq bd (entget be)) (setq bd (subst (cons 2 nb) (assoc 2 bd) bd)) (entmod bd) (entupd be) ) ) ;----------------------------------------------------------------end C:BREP---- ;---------------------------------------------------------------begin C:CCD---- (defun c:ccd () ;Change drawing colors according to correspondence list (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (change_color_dwg) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun change_color_dwg (/ cl ss bl bn) (prompt "\nChange All Drawing Colors.") (setq cl (read_cdf_n "Color Correspondence List" "ccl")) (setq ss (ssget "x")) (change_color_ss ss cl) (setq ll (list_layers)) (foreach ln ll (redef_layer_color ln cl) ) (setq bl (list_blocks)) (foreach bn bl (redef_blk_color bn cl) ) (setq dl (list_dimstyles)) (foreach dn dl (redef_dim_color dn cl) ) ) (defun redef_dim_color (dn cl / dd tmp dcd dce dct ss) (setq dd (tblsearch "DIMSTYLE" dn)) (if (setq tmp (assoc 176 dd)) (progn (setq dcd (cdr tmp)) (if (assoc dcd cl) (setq dcd (cadr (assoc dcd cl))) (setq dcd "") ) ) (setq dcd "") ) (if (setq tmp (assoc 177 dd)) (progn (setq dce (cdr tmp)) (if (assoc dce cl) (setq dce (cadr (assoc dce cl))) (setq dce "") ) ) (setq dce "") ) (if (setq tmp (assoc 178 dd)) (progn (setq dct (cdr tmp)) (if (assoc dct cl) (setq dct (cadr (assoc dct cl))) (setq dct "") ) ) (setq dct "") ) (setq ss (ssget "x" (list '(0 . "DIMENSION") (cons 3 dn)))) (if ss (progn (prompt (strcat "\nRedefining dimension style " dn "...")) (command ".dim" "override" "dimclrd" dcd "dimclre" dce "dimclrt" dct "" ss "" "y" "e") ) ) ) (defun redef_layer_color (lay cl / ld lc lcn nlc) (setq ld (tblsearch "LAYER" lay)) (setq lc (assoc 62 ld)) (if lc (progn (setq lcn (cdr lc)) (if (setq nlc (assoc lcn cl)) (progn (prompt (strcat "\nRedefining layer " lay "...")) (command ".layer" "color" (cadr nlc) lay "") ) ) ) ) ) (defun redef_blk_color (block_name cl / tmp e ss) (prompt (strcat "\nRedefining block " (strcase block_name) "...")) (setq tmp (getvar "EXPERT")) (setvar "EXPERT" 5) (setq e (entlast)) (command ".insert" (strcat "*" block_name) "0,0" 1 "0") (setq ss (ssadd)) (setq e (if e (entnext e) (entnext))) (while e (setq ss (ssadd e ss)) (setq e (entnext e)) ) (change_color_ss ss cl) (command ".block" block_name "0,0" ss "") (setvar "EXPERT" tmp) ) (defun list_blocks (/ bl b bn tf) (setq bl '()) (setq b (tblnext "BLOCK" 1)) (while b (setq tf (cdr (assoc 70 b))) (if (not (bit_check tf (list 1 4 16 32))) ; user-defined block (progn (setq bn (cdr (assoc 2 b))) (setq bl (cons bn bl)) ) ) (setq b (tblnext "BLOCK")) ) bl ) (defun list_dimstyles (/ dl d tf dn) (setq dl '()) (setq d (tblnext "DIMSTYLE" 1)) (while d (setq tf (cdr (assoc 70 d))) (if (not (bit_check tf (list 16))) ; not dependant on xref (progn (setq dn (cdr (assoc 2 d))) ; name (setq dl (cons dn dl)) ) ) (setq d (tblnext "DIMSTYLE")) ) dl ) (defun change_color_ss (ss clist / ndx e) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (change_color_e e clist) ) ) (defun change_color_e (e clist / ed c cn n nc) (setq ed (entget e)) (setq c (assoc 62 ed)) (if c (progn (setq cn (cdr c)) (if (setq n (assoc cn clist)) (progn (setq nc (cadr n)) (setq ed (subst (cons 62 nc) c ed)) (entmod ed) (entupd e) ) ) ) ) ) (defun read_text_file(name ext / ret_list fname f l) (setq ret_list '()) (setq fname (getfiled name (strcat "filename." ext) ext 2)) (setq f (open fname "r")) (while (setq l (read-line f)) (setq ret_list (append ret_list (list l))) ) (close f) ret_list ) (defun read_cdf_file(fname / ret_list ret fname f l) (setq ret_list '()) (setq ret '()) ; (prompt (strcat "\nReading comma-delimited file " fname "...")) (setq f (open fname "r")) (if f (progn (while (setq l (read-line f)) (setq ret (split_string_s l)) (setq ret_list (append ret_list (list ret))) ) (close f) ) ) ret_list ) (defun read_cdf_s(name ext / ret_list ret fname f l) (setq ret_list '()) (setq ret '()) (setq fname (getfiled name (strcat "filename." ext) ext 2)) (setq f (open fname "r")) (while (setq l (read-line f)) (setq ret (split_string_s l)) (setq ret_list (append ret_list (list ret))) ) (close f) ret_list ) (defun read_cdf_s2(fname / ret_list ret fname f l) (setq ret_list '()) (setq ret '()) (setq f (open fname "r")) (while (setq l (read-line f)) (setq ret (split_string_s l)) (setq ret_list (append ret_list (list ret))) ) (close f) ret_list ) (defun read_cdf_n(name ext / ret_list ret fname f l) (setq ret_list '()) (setq ret '()) (setq fname (getfiled name (strcat "filename." ext) ext 2)) (setq f (open fname "r")) (while (setq l (read-line f)) (setq ret (split_string_n l)) (setq ret_list (append ret_list (list ret))) ) (close f) ret_list ) (defun read_cdf_n2 (fname / ret_list ret fname f l i) (setq ret_list '()) (setq ret '()) (setq f (open fname "r")) (setq i 0) (prompt "\nReading CDF File") (while (setq l (read-line f)) (setq ret (split_string_n l)) (setq ret_list (append ret_list (list ret))) (setq i (1+ i)) (if (equal (rem (/ i 100.0)) 0.0) (prompt ".") ) ) (close f) ret_list ) (defun split_string_s(s / ret word) (setq ret '()) ; (setq word (getword 's)) ; (if word ; (cond ; ((equal (type (read word)) 'STR) (setq word (strip_string word))) ; ) ; ) ; (setq ret (append ret (list word))) (while (not (equal s "")) ;(setq s (substr s 2)) (setq word (getword 's)) (if word (cond ((equal (type (read word)) 'STR) (setq word (strip_string word))) ) ) (setq ret (append ret (list word))) ) ret ) (defun split_string_n(s / ret word) (setq ret '()) (setq word (getword 's)) (if word (cond ((equal (type (read word)) 'STR) (setq word (strip_string word))) ((equal (type (read word)) 'REAL) (setq word (read word))) ((equal (type (read word)) 'INT) (setq word (read word))) ) ) (setq ret (append ret (list word))) (while (not (equal s "")) ;(setq s (substr s 2)) (setq word (getword 's)) (if word (cond ((equal (type (read word)) 'STR) (setq word (strip_string word))) ((equal (type (read word)) 'REAL) (setq word (read word))) ((equal (type (read word)) 'INT) (setq word (read word))) ) ) (setq ret (append ret (list word))) ) ret ) (defun getword (ll / numquotes c lc) (setq word "") (setq c (substr (eval ll) 1 1)) (setq lc c) (if (equal c "\"") ; this is a quoted string. ; terminated by a ", or " at end of line ; (setq numquotes (1+ numquotes)) (while (and (not (and (equal lc "\"") (equal c ","))) (not (equal c ""))) (progn (setq lc c) (setq word (strcat word c)) (set ll (substr (eval ll) 2)) (setq c (substr (eval ll) 1 1)) ) ) ) (if (not (equal c "")) ; not a string. ; terminated by a comma, or end of line (while (and (not (equal c ",")) (not (equal c ""))) (progn (setq lc c) (setq word (strcat word c)) (set ll (substr (eval ll) 2)) (setq c (substr (eval ll) 1 1)) ) ) ) (set ll (substr (eval ll) 2)) word ) (defun odd (num) (not (equal (/ num 2.0) (fix (/ num 2.0)))) ) (defun strip_string (s / r c) (setq r "") (setq s (substr s 2)) (setq len (strlen s)) (setq s (substr s 1 (1- len))) ;(setq s (substr s 2)) ;(while (not (equal (substr s 2 1) "")) ; (setq c (substr s 1 1)) ; (setq r (strcat r c)) ; (setq s (substr s 2)) ;) ;r ) ;----------------------------------------------------------------end C:CCD---- ;---------------------------------------------------------------begin C:ED---- (defun c:ed (/ e) (setq e (car (entsel "\nSelect entity: "))) (if e (entget e) (prompt "\nYou didn't select anything...") ) ) ;-----------------------------------------------------------------end C:ED---- ;-------------------------------------------------------------begin C:NEWSS---- (defun c:newss (/ e ss len) (sysvarinit '("cmdecho")) (if LASTENT (setq e LASTENT LASTENT '())) (if (and e (entnext e)) (progn (setq ss (ssadd)) (while e (setq ss (ssadd e ss)) (setq e (entnext e)) ) ) ) (command ".select" ss "") (setq len (sslength ss)) (prompt (strcat "\n" (itoa len) " entities added to \"previous\" selection set.")) (sysvarrestore) (prin1) ) (defun c:newset() (setq LASTENT (entlast)) ) ;---------------------------------------------------------------end C:NEWSS---- ;--------------------------------------------------------------begin C:ATOT---- (defun c:atot () ; Change ATTDEF entities to text entities (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (atot) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun atot() (prompt "\nSelect ATTDEF entities: ") (setq ss (ssget '((0 . "ATTDEF")))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq ae (ssname ss ndx)) (setq ad (entget ae)) (setq td (list '(0 . "TEXT") (assoc 8 ad) (assoc 10 ad) (assoc 40 ad) (cons 1 (cdr (assoc 2 ad))) (assoc 50 ad) (assoc 41 ad) (assoc 51 ad) (assoc 7 ad) (assoc 71 ad) (assoc 72 ad) (cons 73 (cdr (assoc 74 ad))) (assoc 11 ad))) (entdel ae) (entmake td) ) ) ;----------------------------------------------------------------end C:ATOT---- ;--------------------------------------------------------------begin C:FLAT---- (defun c:flat () ; Make lines whose endpoints have different Z coords flat. (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (flat) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun flat(/ ss ndx e ed e1 e2) (prompt "\nSelect lines to remove Z coordinate: ") (setq ss (ssget '((0 . "LINE")))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) ; (if (not (equal (cdr (assoc 0 ed)) "LINE")) ; (progn ; (prompt "\nMust select LINE entity.") ; (exit) ; ) ; ) (setq e1 (cons 10 (mapcar '* '(1.0 1.0 0.0) (cdr (assoc 10 ed))))) (setq e2 (cons 11 (mapcar '* '(1.0 1.0 0.0) (cdr (assoc 11 ed))))) (setq ed (subst e1 (assoc 10 ed) ed)) (setq ed (subst e2 (assoc 11 ed) ed)) (entmod ed) (entupd e) ) ) ;--------------------------------------------------------------begin C:FLAT---- ;--------------------------------------------------------------begin C:STUD---- ; UNDER CONSTRUCTION (defun c:stud () ; draw a stud wall w/ a single layer of GWB on either side (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (stud) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun stud() (setq ll (getpoint "\nLower left point: ")) (setq ur (getpoint "\nUpper right point: ")) (setq llx (car ll) lly (cadr ll) urx (car ur) ury (cadr ur)) (command ".layer" "make" "stud" "color" "6" "" "") (command ".pline" ll (list llx ury 0) ) (command ".layer" "make" "gwb" "color" "7" "" "") ) ;----------------------------------------------------------------end C:STUD---- ;-------------------------------------------------------------begin C:PTRIM---- (defun c:ptrim () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (polyline_trim) (command ".undo" "end") (sysvarrestore) (prin1) ) (setq TRIM_DIST 0.01) (defun polyline_trim(/ pe pt pl) (prompt "\nNOTE: Entire polyline must be visible...") (prompt "\nSelect polyline to trim to: ") (setq pe (entsel)) (setq pt (getpoint "\nPick point on inside or outside: ")) (command ".offset" TRIM_DIST pe pt "") (setq pl (make_vertex_pt_list (entlast))) (entdel (entlast)) (setq pl (append pl (list (car pl)))) (repeat 2 (command ".trim" pe "" "f") (foreach pt pl (command pt) ) (command "" "") ) ) (defun get_average_pt (pt_list / len x y z pt) (setq len (length pt_list) x 0 y 0 z 0 ) (foreach pt pt_list (setq x (+ (car pt) x) y (+ (cadr pt) y) ; z (+ (caddr pt) z) ) ) (if (= len 0) nil ; (list (/ x len) (/ y len) (/ z len)) (list (/ x len) (/ y len)) ) ) ;---------------------------------------------------------------end C:PTRIM---- ;-------------------------------------------------------------begin C:CLINE---- (defun c:cline () (sysvarinit '("cmdecho" "blipmode" "orthomode")) (command ".undo" "group") (center_line) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun center_line(/ ss e1 e2 vcl) (prompt "\nSelect two lines to bisect: ") (setq ss (ssget '((0 . "LINE")))) (if ss (if (equal (sslength ss) 2) (progn (setq e1 (ssname ss 0)) (setq e2 (ssname ss 1)) (setq vcl (make_virtual_center_line e1 e2)) (command ".line" (car vcl) (cadr vcl) "") ; (command ".chprop" "l" "" "lt" "center2" "") ) (prompt "\nMust select TWO lines.") ) ) ) ;---------------------------------------------------------------end C:CLINE---- ;----------------------------------------------------------------begin C:DA---- (defun c:da () (sysvarinit '("cmdecho" "blipmode" "orthomode")) (command ".undo" "group") (draw_area) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun draw_area (/ a l1 l2 ll lr ur ul) (setq a (getreal "\nArea \(Square Feet\): ")) (setq a (* a 144.0)) (setq l1 (getdist "\nLength 1: ")) (setq l2 (/ a l1)) (setq ll (getpoint "\nLower left corner: ")) (setq lr (mapcar '+ ll (list l2 0.0 0.0))) (setq ur (mapcar '+ ll (list l2 l1 0.0))) (setq ul (mapcar '+ ll (list 0.0 l1 0.0))) (command ".pline" ll ul ur lr "c") ) ;------------------------------------------------------------------end C:DA---- ;---------------------------------------------------------------begin C:DPV---- (defun c:dpv () (sysvarinit '("cmdecho" "blipmode" "orthomode")) (command ".undo" "group") (pl_vert_del) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun pl_vert_del (/ p_ent pt pl v v_list) (setq p_ent nil) (while (not (equal (cdr (assoc 0 (setq pl (entget (setq p_ent (car (entsel))))))) PL_NAME)) (prompt "\nDelete vertex in which polyline: ") ) (setq pl (cdr pl)) (initget 1) (setq pt (getpoint "\nPolyline vertex to delete \(enter point\): ")) (setq v p_ent) (setq v_list nil) (while (not (equal (cdr (assoc 0 (entget (setq v (entnext v))))) "SEQEND")) (setq vd (entget v)) (setq v_pt (cdr (assoc 10 vd))) (if (not (equal v_pt pt)) (setq v_list (append v_list (list (entget v)))) ) ) (entdel p_ent) (entmake pl) (foreach v v_list (entmake v)) (entmake '((0 . "SEQEND"))) (entupd (entlast)) ) ;-----------------------------------------------------------------end C:DPV---- ;----------------------------------------------------------begin C:PL_WIDTH---- (defun c:pl_width(/ tmp) (sysvarinit '("cmdecho" "blipmode" "orthomode")) (command ".undo" "group") (setq tmp (getvar "EXPERT")) (setvar "EXPERT" 5) (pl_width) (command ".undo" "end") (sysvarrestore) (setvar "EXPERT" tmp) (prin1) ) (defun pl_width(/ filt ss wid ndx e ed et) (prompt "\nSelect lines and polylines: ") ; (setq filt (list '(-4 . ""))) ; (setq ss (ssget filt)) (setq ss (ssget (list (cons 0 PL_NAME)))) (setq wid (getdist "\nWidth for all segments: ")) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) (setq et (cdr (assoc 0 ed))) (if (equal et "LINE") (command ".pedit" e "y" "w" wid "") (command ".pedit" e "w" wid "") ) ) ) ;----------------------------------------------------------begin C:PL_WIDTH---- ;----------------------------------------------------------------begin C:PA---- (defun c:pa() (sysvarinit '("cmdecho" "blipmode" "orthomode")) (command ".undo" "group") (polar_array) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun polar_array(/ ss ang pt num) (prompt "\nSelect objects to polar array: ") (setq ss (ssget)) (setq ang (getangle "\nAngle to rotate: ")) (setq pt (getpoint "\nBase point: ")) (setq num (getint "\nNumber of elements in array: ")) (repeat num (command ".copy" ss "" "0,0" "") (command ".rotate" ss "" pt (angtos ang)) ) ) ;------------------------------------------------------------------end C:PA---- ;----------------------------------------------------------------begin C:SM---- (defun c:sm() (sysvarinit '("cmdecho" "blipmode" "orthomode")) (command ".undo" "group") (scale_many) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun scale_many(/ s ss ndx e ins) (setq s (getdist "\nScale factor: ")) (setq ss (ssget '((-4 . "")))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ins (cdr (assoc 10 (entget e)))) (command ".scale" e "" ins s) ) ) ;------------------------------------------------------------------end C:SM---- ;----------------------------------------------------------------begin C:RM---- (defun c:rm() (sysvarinit '("cmdecho" "blipmode" "orthomode")) (command ".undo" "group") (rotate_many) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun rotate_many(/ s ss ndx e ins) (setq s (getangle "\nRotation angle: ")) (setq s (angtos s)) (setq ss (ssget '((-4 . "")))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ins (cdr (assoc 10 (entget e)))) (command ".rotate" e "" ins s) ) ) ;------------------------------------------------------------------end C:RM---- ;----------------------------------------------------------------begin C:SM---- (defun c:bsm() (sysvarinit '("cmdecho" "blipmode" "orthomode")) (command ".undo" "group") (block_scale_many) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun block_scale_many(/ s ss ndx e ed) (setq s (getdist "\nScale factor: ")) (setq ss (ssget '((0 . "INSERT")))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) (setq ed (set_code ed 41 s)) (setq ed (set_code ed 42 s)) ; (setq ed (set_code ed 43 s)) (entmod ed) (entupd e) ) ) ;------------------------------------------------------------------end C:SM---- (defun set_code (ed code val) (if (assoc code ed) (setq ed (subst (cons code val) (assoc code ed) ed)) (setq ed (cons (cons code val) ed)) ) ed ) ;--------------------------------------------------------------begin C:BFIX---- (defun c:bfix() (sysvarinit '("cmdecho" "blipmode" "orthomode")) (command ".undo" "group") (block_fix) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun block_fix (/ regtemp b-name bd) ;; Recursively redefine all blocks in a drawing so that ;; their entities are on layer 0, and color BYBLOCK. (command ".undo" "group") (setq regtemp (getvar "regenmode")) (setvar "regenmode" 0) (prompt "\nSelect blocks to redefine: ") (setq bnames (get_bnames)) (initget 1 "Block Layer") (setq col (getkword "\nInternal entity color BYBLOCK or BYLAYER \(B or L\): ")) (if (= col "Block") (setq col 0) (setq col 256) ) (foreach b-name bnames (if (user_block b-name) (progn (prompt (strcat "\nRedefining block " b-name "...")) (bchange b-name 8 "0") ;Set to layer "0". (bchange b-name 62 col) ;Set color BYBLOCK or BYLAYER (b_att_change b-name 8 "0") ;Set to layer "0". (b_att_change b-name 62 col) ;Set color BYBLOCK or BYLAYER ) (prompt (strcat "\nBlock " b-name " not user-defined...")) ) (if (setq bd (tblnext "BLOCK")) (setq b-name (cdr (assoc 2 bd))) ) ) (setvar "regenmode" regtemp) (command ".undo" "end") (prin1) ) (defun get_bnames(/ bn_list ss ndx be bn) (setq bn_list '()) (prompt "\nSelect blocks to create list of block names: ") (setq ss (ssget '((0 . "INSERT")))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq be (ssname ss ndx)) (setq bn (cdr (assoc 2 (entget be)))) (if (and (not (member bn bn_list)) (user_block bn)) (setq bn_list (cons bn bn_list)) ) ) (setq bn_list (sort_strings bn_list)) (show_strings bn_list) bn_list ) (defun bchange (block_name gp_code value / e ss ed old tmp) ;; Change value of a group code for all entities comprising a ;; a block - recursive. (setq tmp (getvar "EXPERT")) (setvar "EXPERT" 5) (if (equal "12" (acad_ver)) (command ".layer" "unlock" "0" "thaw" "0" "on" "0" "") (command ".layer" "thaw" "0" "on" "0" "") ) (if (not (equal (getvar "CLAYER") "0")) (command ".layer" "set" "0" "") ) (setq e (entlast)) (command ".insert" (strcat "*" block_name) "0,0" 1 "0") (setq ss (ssadd)) (setq e (if e (entnext e) (entnext))) (while e (setq ed (entget e)) (if (equal (cdr (assoc 0 ed)) "INSERT") (if (user_block (cdr (assoc 2 ed))) (bchange (cdr (assoc 2 ed)) gp_code value) ) ) (setq old (assoc gp_code ed)) (if (= old nil) (setq ed (cons (cons gp_code value) ed)) (setq ed (subst (cons gp_code value) old ed ) ) ) (entmod ed) (setq ss (ssadd e ss)) (setq e (entnext e)) ) (command ".block" block_name "0,0" ss "") (setvar "EXPERT" tmp) ) (defun b_att_change (block_name gp_code value / ss ndx b-ent ent ed) ;; Change a group code value for all attributes associated ;; with a block name. (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 block_name)))) (if ss (progn (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq b-ent (ssname ss ndx)) (setq ent b-ent) (if (has_attr? ent) (progn (while (not (equal (get_ent_type (setq ent (entnext ent))) "SEQEND")) (setq ed (entget ent)) (if (equal (assoc gp_code ed) nil) (setq ed (cons (cons gp_code value) ed)) (setq ed (subst (cons gp_code value) (assoc gp_code ed) ed ) ) ) (entmod ed) ) ) ) ) )) ) (defun has_attr? (ent / gp) (and (setq gp (assoc 66 (entget ent))) (not (equal (cdr gp) 0)) ) ) (defun get_ent_type (ent) (cdr (assoc 0 (entget ent))) ) (defun user_block (bname / bd tf) (setq bd (tblsearch "BLOCK" bname)) (setq tf (cdr (assoc 70 bd))) (not (bit_check tf (list 1 4 8 16 32))) ) (defun acad_ver (/ version index verlen) (setq version (getvar "ACADVER" )) (setq index 1) (setq verlen (strlen version)) (while (and (< index verlen) (not (equal "12" (substr version index 2)))) (setq index (1+ index))) (if (= index verlen) "11" "12" ) ) ;----------------------------------------------------------------end C:BFIX---- ;------------------------------------------------------------------------------ (defun c:bln() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (clean_block_names) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun clean_block_names(/ bd bn nbn) (setq bd (tblnext "BLOCK" 1)) (while bd (setq bn (cdr (assoc 2 bd))) (setq nbn (name_strip bn)) (if (not (equal bn nbn)) (block_name_change bn nbn) ) (setq bd (tblnext "BLOCK")) ) ) (defun block_name_change( bn nbn / i suffix ncheck) (setq i 0) (setq suffix "") (setq ncheck (strcat nbn suffix)) (while (tblsearch "BLOCK" ncheck) (setq i (1+ i)) (setq suffix (itoa i)) (setq ncheck (strcat nbn suffix)) ) (prompt (strcat "\nRenamed block " bn " to " ncheck)) (command ".rename" "block" bn ncheck) ) (defun c:cln() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (clean_layer_names) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun clean_layer_names(/ ld ln nln ss) (setq ld (tblnext "LAYER" 1)) (while ld (setq ln (cdr (assoc 2 ld))) (setq nln (name_strip ln)) ; (setq nln (dc_name_strip ln)) (if (not (equal nln ln)) (layer_name_change ln nln) ) (setq ld (tblnext "LAYER")) ) ) (defun c:lnc () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (lnc) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun lnc (/ ll l ol nl) (setq ll (read_cdf_s "Layer Correspondence List" "")) (foreach l ll (setq ol (car l) nl (cadr l)) (layer_name_change ol nl) ) ) (defun layer_name_change (oln nln / ss) (if (tblsearch "LAYER" oln) (progn (if (tblsearch "LAYER" nln) (progn (setq ss (ssget "x" (list (cons 8 oln)))) (if ss ; (command ".change" ss "" "p" "la" nln "") (do_command ".change" (list ss "" "p" "la" nln "")) ) ) (command ".rename" "layer" oln nln) ) (prompt (strcat "\nChanged layer " (strcase oln) " to layer " (strcase nln))) ) ) ) (defun do_command (cmd plist) (command cmd) (while (and (> (getvar "CMDACTIVE") 0) plist) (command (car plist)) (setq plist (cdr plist)) ) ) (defun dc_name_strip (name / pref) (setq pref (substr name 1 3)) (if (equal pref "DC_") (substr name 4) name ) ) (defun name_strip (name / len new_name c) (setq len (1+ (strlen name))) (setq new_name "") (while (> (setq len (1- len)) 0) (setq c (substr name len 1)) (if (not (= c "$")) (setq new_name (strcat c new_name)) (setq len 0) ) ) new_name ) ;------------------------------------------------------------------------------ ;------------------------------------------------------------------------------ (defun c:pac() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (polyline_area_copy) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun polyline_area_copy(/ ss ndx pe a pl bs ndx2 be) (prompt "\nSelect room boundarys: ") (prompt (strcat "\nArea will be divided by " (rtos AREA_FACTOR 2 1))) (setq ss (ssget (list (cons 0 PL_NAME)))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq pe (ssname ss ndx)) (command ".area" "e" (list pe '(0.0 0.0 0.0))) (setq a (/ (getvar "AREA") AREA_FACTOR)) (setq a (rtos a 2 1)) (setq pl (make_vertex_pt_list pe)) (setq bs (ssget "wp" pl '((0 . "INSERT")))) (setq ndx2 (sslength bs)) (while (>= (setq ndx2 (1- ndx2)) 0) (setq be (ssname bs ndx2)) (change_attrib_value be TAG_AREA a) ) ) ) ;------------------------------------------------------------------------------ (defun c:dnd_color() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (dnd_color_polylines) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun dnd_color_polylines(/ dlay clay cl dwg ncl item ll ssfilt l ss ndx pe pd play blist blk spid spid_col be bd ins) (command ".fill" "on") (setq dlay (getstring "\nLayer to draw theme on: ")) (setq clay (getvar "CLAYER")) (command ".layer" "make" dlay "") (setq cl (read_cdf_s "Color Correspondence List" "csv")) ;dwgname,space_id,color (setq dwg (strcase (path_strip (getvar "DWGNAME")))) (setq ncl '()) (foreach item cl (if (equal (strcase (car item)) dwg) (setq ncl (cons (list (cadr item) (caddr item)) ncl)) ) ); ncl is an association list of space_id's and colors for the current drawing (downsize) (setq ll (read_cdf_file DND_DATA_LAYERS)) (setq ssfilt '((-4 . "OR>"))) (foreach l ll (setq ssfilt (cons (cons 8 (car l)) ssfilt)) ) (setq ssfilt (cons '(-4 . "")) ssfilt)) (setq ss (ssget "x" ssfilt)) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq pe (ssname ss ndx)) (setq pd (entget pe)) (setq play (cdr (assoc 8 pd))) (setq blist (sel_pl_blks pe "*" play)) ;all blocks within pe on same layer as pe (foreach blk blist (setq spid (get_attrib_value blk TAG_SPACEID)) (setq spid (pad_string spid "0" 3)) (if spid (if (setq spid_col (assoc spid ncl)) (progn (setq spid_col (atoi (cadr spid_col))) (if (and (> spid_col 0) (< spid_col 255)) (progn (command ".color" spid_col) (command ".hatch" "solid" pe "") ; (command ".chprop" pe "" "color" spid_col "") ) ) ) ) ) ) (setq blist '()) ) (prompt "\nChanging draworder, please wait...") (upsize) (setq ssfilt '((-4 . "OR>"))) (foreach l ll (setq ssfilt (cons (cons 8 (car l)) ssfilt)) ) (setq ssfilt (cons '(-4 . "")) ssfilt)) (setq ss (ssget "x" ssfilt)) ; (command ".draworder" (ssget "x" (list (cons 8 dlay))) "" "") (command ".draworder" ss "" "front") (command ".color" "bylayer") (command ".layer" "set" clay "") (command ".regen") ) (defun downsize (/ ssfilt l ll ss ndx be bd ins) (setq ll (read_cdf_file DND_DATA_LAYERS)) (setq ssfilt '((-4 . "OR>"))) (foreach l ll (setq ssfilt (cons (cons 8 (car l)) ssfilt)) ) (setq ssfilt (cons '(-4 . "= (setq ndx (1- ndx)) 0) (setq be (ssname ss ndx)) (setq bd (entget be)) (setq ins (cdr (assoc 10 bd))) (command ".scale" be "" ins REDUCTION_FACTOR) ) ) (defun upsize (/ ssfilt l ll ss ndx be bd ins) (setq ll (read_cdf_file DND_DATA_LAYERS)) (setq ssfilt '((-4 . "OR>"))) (foreach l ll (setq ssfilt (cons (cons 8 (car l)) ssfilt)) ) (setq ssfilt (cons '(-4 . "= (setq ndx (1- ndx)) 0) (setq be (ssname ss ndx)) (setq bd (entget be)) (setq ins (cdr (assoc 10 bd))) (command ".scale" be "" ins (/ 1.0 REDUCTION_FACTOR)) ) ) (defun pad_string (s c len / ns l) (setq ns "") (setq l (strlen s)) (if (>= l len) (setq ns s) (progn (repeat (- len l) (setq ns (strcat ns c)) ) (setq ns (strcat ns s)) ) ) ns ) ;------------------------------------------------------------------------------ (defun c:pdw() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (polyline_data_write) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun polyline_data_write(/ fname dwg xd nd d f ll l ssfilt ss ndx be bd headers) ; (setq fname (getvar "DWGNAME")) ; (setq fname (strcase (path_strip fname))) ; (setq fname (strcat (getvar "DWGPREFIX") fname)) ; (setq fname (strcat fname ".CSV")) (setq fname DNDDATA_FILENAME) (setq dwg (getvar "DWGNAME")) (setq dwg (strcase (path_strip dwg))) (setq xd (read_cdf_file fname)) (if (> (length xd) 1);remove header row (setq xd (cdr xd)) ) (setq nd '()) (foreach d xd (if (not (member dwg d)) (progn (setq d (make_cdf d)) (setq nd (cons d nd)) ) ) ) (setq ll (read_cdf_file DND_DATA_LAYERS)) (setq ssfilt '((-4 . "OR>"))) (foreach l ll (setq ssfilt (cons (cons 8 (car l)) ssfilt)) ) (setq ssfilt (cons '(-4 . "= (setq ndx (1- ndx)) 0) (setq be (ssname ss ndx)) (setq bd (get_bdata be)) (setq bd (make_cdf bd)) (setq nd (cons bd nd)) ) (setq headers (get_tags be)) (setq headers (make_cdf headers)) (prompt (strcat "\nWriting data file " fname "...")) (setq f (open fname "w")) (write-line headers f) (foreach d nd (write-line d f) ) (close f) (prompt "done.") ) (defun get_tags(ent / dl ed) (setq dl '()) (while (/= (cdr (assoc 0 (setq ed (entget (setq ent (entnext ent)))))) "SEQEND") (if (equal (cdr (assoc 0 ed)) "ATTRIB") (setq dl (append dl (list (strcase (cdr (assoc 2 ed)))))) ) ) dl ) (defun c:phe() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (pline_hatch_erase) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun pline_hatch_erase (/ ll ssfilt l ss) (setq ll (read_cdf_file DND_DATA_LAYERS)) (setq ssfilt '((-4 . "OR>"))) (foreach l ll (setq ssfilt (cons (cons 8 (car l)) ssfilt)) ) (setq ssfilt (cons '(-4 . "") (-4 . "OR>")) ssfilt)) (setq ss (ssget "x" ssfilt)) (if ss (command ".erase" ss "") ) ) (defun c:pdc() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (polyline_data_copy) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun polyline_data_copy (/ ll lay) (pline_hatch_erase) (downsize) (setq ll (read_cdf_file DND_DATA_LAYERS)) (foreach lay ll (pl_areas_to_blks (car lay)) ) (upsize) ) (defun pl_areas_to_blks (lay / bcnt pen ped play ben bed bnam blay ss ndx pfl closed astr blst blk dwg clay ndc) (prompt "\nCopying areas to blocks...") (setq clay (getvar "CVLAYER")) (command ".layer" "make" lay "") (setq bcnt 0) (setq blay lay play lay) (setq bnam "*") (setq dwg (getvar "DWGNAME")) (setq dwg (strcase (strcat (getvar "DWGPREFIX") dwg))) ; (setq dwg (strcase (path_strip dwg))) ; (setq pen (get_pline_ename)) ; (setq ped (entget pen)) ; (setq play (cdr (assoc 8 ped))) ; (setq ben (get_block_ename)) ; (setq bed (entget ben)) ; (setq bnam (cdr (assoc 2 bed))) ; (setq blay (cdr (assoc 8 bed))) (prompt (strcat "\n\nCopying polyline areas on layer " play)) (prompt (strcat "\nto enclosed blocks on layer " blay "...")) (setq ss (ssget "x" (list '(0 . "INSERT") (cons 2 bnam) (cons 8 play)))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq blk (ssname ss ndx)) (prompt (strcat "\nResetting block " (itoa ndx) )) (change_attrib_value blk TAG_AREA "") (change_attrib_value blk TAG_LAYER "") (change_attrib_value blk TAG_DWGFILE "") ); set all relevant block tags to zero (setq ss (ssget "x" (list (cons 0 PL_NAME) (cons 8 play)))) (if ss (progn (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (prompt (strcat "\nChecking polyline " (itoa ndx))) (setq pen (ssname ss ndx)) (setq ped (entget pen)) (setq pfl (cdr (assoc 70 ped))) (setq closed (bit_check pfl '(1))) ;T if polyline is closed (if closed (progn (command ".pedit" (list pen '(0.0 0.0 0.0)) "w" "0.0" "") (command ".chprop" pen "" "color" "BYLAYER" "") (setq astr (get_area_sf pen)) (setq blst (sel_pl_blks pen bnam blay)) (foreach blk blst (change_attrib_value blk TAG_AREA astr) (change_attrib_value blk TAG_LAYER lay) (change_attrib_value blk TAG_DWGFILE dwg) (setq bcnt (1+ bcnt)) ) (if (equal blst '()); no blocks inside of polyline (command ".hatch" "u" "45" 36 "n" pen "") ) ) (progn (command ".pedit" (list pen '(0.0 0.0 0.0)) "w" "18.0" "") (command ".chprop" pen "" "color" "1" "") ) ) ) ) ) (setq ss (ssget "x" (list '(0 . "INSERT") (cons 2 bnam) (cons 8 play)))) (setq ndx (sslength ss)) (setq ndc 0) (while (>= (setq ndx (1- ndx)) 0) (setq blk (ssname ss ndx)) (setq lay (get_attrib_value blk TAG_LAYER)) (if (equal lay ""); block has no enclosing polyline (setq ndc (1+ ndc)) ) ) (command ".layer" "set" clay "") (prompt (strcat "\nDone - " (itoa bcnt) " blocks.")) (if (> ndc 0) (prompt (strcat "\n" (itoa ndc) " blocks had no surrounding polyline.")) ) ) (defun c:pflat() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (polyline_flatten) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun polyline_flatten(/ ss ndx pe vl v pl cl) (prompt "\nSelect polylines to flatten: ") (setq ss (ssget '((-4 . "")))) (setq ndx (sslength ss)) (setq cl (getvar "CLAYER")) (while (>= (setq ndx (1- ndx)) 0) (setq pe (ssname ss ndx)) (setq pl (cdr (assoc 8 (entget pe)))) (command ".layer" "set" pl "") (setq pfl (cdr (assoc 70 (entget pe)))) (setq closed (bit_check pfl '(1))) ;T if polyline is closed (setq vl (make_vertex_pt_list pe)) (entdel pe) (command ".pline") (foreach v vl (setq v (list (car v) (cadr v))) (command v) ) (if closed (command "c") (command "") ) ) (command ".layer" "set" cl "") ) (defun draw_pline (plst / p) (command ".pline") (foreach p plst (command p) ) (command "") ) (defun draw_cpline (plst / p) (command ".pline") (foreach p plst (command p) ) (command "c") ) (defun sel_pl_blks (pen bnam blay / blst pvl ss ndx ben) (setq blst '()) (setq pvl (make_vertex_pt_list pen)) (if (< (length pvl) 3) (prompt "\nInvalid polyline...") (progn (setq ss (ssget "cp" pvl (list '(0 . "INSERT") (cons 2 bnam) (cons 8 blay)))) (if ss (progn (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq ben (ssname ss ndx)) (setq blst (cons ben blst)) ) ) (prompt "\nPolyline has no corresponding blocks.") ) ) ) blst ) (defun get_pline_ename(/ e ed et) (prompt "\nSelect polyline: ") (setq e (car (entsel))) (if e (progn (setq ed (entget e)) (setq et (cdr (assoc 0 ed))) ) (setq et "") ) (while (not (equal et PL_NAME)) (prompt "\nNot a polyline. Try again...") (setq e (car (entsel))) (if e (progn (setq ed (entget e)) (setq et (cdr (assoc 0 ed))) ) (setq et "") ) ) e ) ;return string indicating s.f. area of polyline or region entity (defun get_area_sf (en / a) (command ".area" "e" (list en '(0 0 0))) (setq a (/ (getvar "AREA") 144.0)) (rtos a 2 1) ) ;------------------------------------------------------------------------------ ;------------------------------------------------------------------------------ (defun c:wbd() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (write_block_data) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun write_block_data(/ blockdata fname dwg f b) (setq blockdata (list_block_data)) (setq fname (getfiled "Delimited Text File" "filename.csv" "csv" 1)) (setq dwg (getvar "DWGNAME")) (setq dwg (path_strip dwg)) (setq dwg (strcat "j:/bpa/dwg/" dwg ".txt")) (setq f (open fname "a")) (foreach b blockdata (setq b (make_cdf b)) (write-line b f) ) (close f) ) (defun list_block_data(/ bdl bd bn ss ndx be) (setq bdl '()) (setq bn (get_block_name)) (setq ss (ssget (list '(0 . "INSERT") (cons 2 bn)))) ; (setq ss (ssget "x" (list '(0 . "INSERT") (cons 2 bn)))) (setq ndx (sslength ss)) (prompt "\nGetting data...") (while (>= (setq ndx (1- ndx)) 0) (setq be (ssname ss ndx)) (setq bd (get_bdata be)) (setq bdl (cons bd bdl)) ) (prompt "\nSorting data...") (setq bdl (sort_strlist_list bdl)) bdl ) (defun sort_strlist_list (strlist) (shell_sort strlist '(lambda (x y) (> (strcase (car x)) (strcase (car y))))) ) (defun get_block_ename(/ e ed et) (prompt "\nSelect block: ") (setq e (car (entsel))) (if e (progn (setq ed (entget e)) (setq et (cdr (assoc 0 ed))) ) (setq et "") ) (while (not (equal et "INSERT")) (prompt "\nNot a block. Try again...") (setq e (car (entsel))) (if e (progn (setq ed (entget e)) (setq et (cdr (assoc 0 ed))) ) (setq et "") ) ) e ) (defun get_block_name(/ e ed et) (setq e (get_block_ename)) (setq ed (entget e)) (cdr (assoc 2 ed)) ) (defun get_att (b_ename / data_list ent tst ed txt_ins txt_hght txt_jst) (setq data_list nil) (setq ent b_ename) (setq txt_ins '()) (while (/= (cdr (assoc 0 (setq ed (entget (setq ent (entnext ent)))))) "SEQEND") (if (equal (cdr (assoc 0 ed)) "ATTRIB") (progn (setq data_list (cons (cons (cdr (assoc 2 ed)) (cdr (assoc 1 ed)) ) data_list ) ) (if (equal txt_ins '()) (setq txt_ins (cdr (assoc 10 ed))) ) (setq tst (cdr (assoc 10 ed))) (if (< (cadr tst) (cadr txt_ins)) (setq txt_ins tst) ) (setq txt_hght (cdr (assoc 40 ed))) ; (setq txt_jst (get_just ed)) ) ) ) (setq data_list (cons (list txt_ins txt_hght txt_jst) data_list)) ) (defun get_att2 (b_ename / data_list ent ed) (setq data_list nil) (setq ent b_ename) (while (/= (cdr (assoc 0 (setq ed (entget (setq ent (entnext ent)))))) "SEQEND") (if (equal (cdr (assoc 0 ed)) "ATTRIB") (progn (setq data_list (cons (cons (cdr (assoc 2 ed)) (cdr (assoc 1 ed)) ) data_list ) ) ) ) ) data_list ) ;-----------------------------------------------------------BEGIN C:BREPATT---- (defun c:brepatt() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode" "attreq")) (command ".undo" "group") (brepatt) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun brepatt (/ bnames ssfilt ss nbname ndx be nbe dat) (setq bnames (get_bnames)) (setq ssfilt '((-4 . "OR>"))) (while bnames (setq ssfilt (cons (cons 2 (car bnames)) ssfilt)) (setq bnames (cdr bnames)) ) (setq ssfilt (cons '(-4 . "= (setq ndx (1- ndx)) 0) (setq be (ssname ss ndx)) (setq nbe (insert_sim_block nbname be)) (setq dat (get_att2 be)) (add_bdata nbe dat) (entdel be) ) ) ;-------------------------------------------------------------END C:BREPATT---- (defun insert_sim_block (bname be / bed ins xsc ysc zsc rot) (setq bed (entget be)) (setq ins (cdr (assoc 10 bed))) (if (assoc 41 bed) (setq xsc (cdr (assoc 41 bed))) (setq xsc 1.0) ) (if (assoc 42 bed) (setq ysc (cdr (assoc 42 bed))) (setq ysc 1.0) ) (if (assoc 43 bed) (setq zsc (cdr (assoc 43 bed))) (setq zsc 1.0) ) (if (assoc 50 bed) (setq rot (cdr (assoc 50 bed))) (setq rot 1.0) ) (setq rot (* rot (/ (* 2.0 PI) 360.0))) (command ".insert" bname ins "XYZ" xsc ysc zsc rot) (entlast) ) (defun add_bdata (be dlist / item tag val) (foreach item dlist (setq tag (car item) val (cdr item)) (change_attrib_value be tag val) ) ) (defun get_bdata (b_ename / dl ent ed) (setq dl '()) (setq ent b_ename) (while (/= (cdr (assoc 0 (setq ed (entget (setq ent (entnext ent)))))) "SEQEND") (if (equal (cdr (assoc 0 ed)) "ATTRIB") (setq dl (append dl (list (strcase (cdr (assoc 1 ed)))))) ) ) ; (make_cdf dl) dl ) (defun make_cdf(l / cd) (setq cd '()) (if (> (length l) 0) (progn (setq cd (strcat "\"" (car l) "\"")) (setq l (cdr l)) (while l (setq cd (strcat cd ",\"" (car l) "\"")) (setq l (cdr l)) ) ) ) cd ) (defun get_just (ed / h_flag v_flag just) (setq h_flag (cdr (assoc 72 ed))) (setq v_flag (cdr (assoc 73 ed))) (cond ((and (= h_flag 1) (= v_flag 0)) (setq just "C")) ((and (= h_flag 1) (= v_flag 2)) (setq just "M")) ((and (= h_flag 2) (= v_flag 0)) (setq just "R")) ((and (= h_flag 2) (= v_flag 3)) (setq just "V")) ((and (= h_flag 0) (= v_flag 3)) (setq just "U")) (T (setq just "X")) ) just ) ;------------------------------------------------------------------------------ (defun c:dis() (prompt "\nDistance: ") (getdist) ) (defun c:ca(/ tmp) (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (setq tmp (getvar "expert")) (setvar "expert" 5) (command ".undo" "group") (continue_annotate) (command ".undo" "end") (sysvarrestore) (setvar "expert" tmp) (prin1) ) (defun continue_annotate(/ e ed lay sty ins hig ins) (setq e (car (entsel))) (setq ed (entget e)) (if (not (equal (cdr (assoc 0 ed)) "TEXT")) (progn (prompt "\nNot a TEXT entity...") (exit) ) ) (setq lay (cdr (assoc 8 ed))) (setq sty (cdr (assoc 7 ed))) (setq ins (cdr (assoc 10 ed))) (setq hig (cdr (assoc 40 ed))) (setq ins (mapcar '- ins (list 0.0 (* hig 1.61905) 0.0))) (setvar "TEXTSTYLE" sty) (setvar "TEXTSIZE" hig) (command ".layer" "set" lay "") (command ".dtext" ins "" "" /) ) (defun c:readtext() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (read_text) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun read_text(/ fname pt rh th tl tw s item) (setq tl (read_text_file "Text File" "")) (setq pt (getpoint "\nStart first line at point: ")) (setq rh (getdist "\nRow height: ")) (setq th (getdist "\nText height: ")) (foreach item tl (command ".text" pt th "" item) (setq pt (mapcar '- pt (list 0.0 rh 0.0))) ) ) ;----------------------------------------------------------------begin C:RT---- (defun c:rt() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (read_delimited_text) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun read_delimited_text(/ fname pt rh th tl tw s item) (setq tl (read_cdf_s "Delimited Text File" "")) (setq pt (getpoint "\nStart first line at point: ")) (setq rh (getdist "\nRow height: ")) (setq th (getdist "\nText height: ")) (setq tw (getdist "\nColumn width: ")) (foreach item tl (setq ins pt) (foreach s item (command ".text" ins th "" s) (setq ins (mapcar '+ ins (list tw 0.0 0.0))) ) (setq pt (mapcar '- pt (list 0.0 rh 0.0))) ) ) ;------------------------------------------------------------------end C:RT---- ; Given a string, and a list of characters considered to be ; seperators, such as commas, spaces, tabs, etc. - return a LIST ; of strings. The comnt_list contains characters which begin ; comments not to be read - like the semicolon at the beginning ; of these comments. ;**************************************************************** (defun str2lst3 (string break_list comnt_list / len ndx s_list word c cp) (setq len (strlen string) ndx 0 s_list '() word "" stop nil c (c_nth ndx string)) ; Get _nth_ character in string. (while (not (or (member c comnt_list) (equal c nil))) (if (member c break_list) (progn (setq s_list (append s_list (list word))) (setq word "") ) (setq word (strcat word c)) ) (setq ndx (1+ ndx)) (setq cp c) (setq c (c_nth ndx string)) ) (if (not (equal word "")) (setq s_list (append s_list (list word))) (if (member cp break_list) (setq s_list (append s_list (list word))) ) ) s_list ) (defun list_style_fonts (/ sl s name pf bf) (setq sl '()) (setq s (tblnext "STYLE" 1)) (while (not (equal s '())) (setq name (strcase (cdr (assoc 2 s))) pf (strcase (cdr (assoc 3 s))) bf (strcase (cdr (assoc 4 s))) ) (setq sl (append sl (list (list name pf bf)))) (setq s (tblnext "STYLE")) ) sl ) (defun c:bubble() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (bubble) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun c:bub() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (pline_bubble) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun bubble (/ i p1 ep pt cen p1 el fp) (prompt "\nDraw bubble boundary...") (setq i 0) (setq p1 (getpoint (strcat "\nPoint " (itoa (setq i (1+ i))) ": "))) (setq ep '()) (setq pt p1 fp p1) (while pt (setq pt (getpoint p1 (strcat "\nPoint " (itoa (setq i (1+ i))) ": "))) (if pt (progn (setq cen (get_midpoint p1 pt)) (command ".arc" p1 "E" pt cen) (setq p1 pt) (setq el (entlast)) (if ep (command ".pedit" (list el pt) "y" "join" ep "" "x") ) (setq ep (entlast)) ) ) ) (prompt "\nDone.") ) (defun pline_bubble (/ pl bn el e p0 p1 et p2 cen ep ss) (setq ss (ssadd)) (setq pl (entsel "\nPick polyline: ")) (setq bd (getdist "\nBubble length: ")) (setq el (entlast)) (command ".measure" pl bd) (setq e (entnext el)) (while (not (equal (cdr (assoc 0 (entget e))) "POINT")) (setq e (entnext e)) ) (setq p0 (cdr (assoc 10 (entget e)))) (entdel e) (setq p1 p0) (setq e (entnext e)) (setq et (cdr (assoc 0 (entget e)))) (while (equal et "POINT") (setq p2 (cdr (assoc 10 (entget e)))) (entdel e) (setq cen (get_midpoint p1 p2)) (command ".arc" p1 "E" p2 cen) (ssadd (entlast) ss) (setq p1 p2) (setq el (entlast)) (setq e (entnext e)) (setq et (cdr (assoc 0 (entget e)))) ) (setq cen (get_midpoint p2 p0)) (command ".arc" p2 "E" p0 cen) (command ".pedit" (list (entlast) p2) "y" "join" ss "" "x") (entdel (car pl)) (setq ss '()) ) (defun c:cds() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (change_dimension_style) (command ".undo" "end") (sysvarrestore) (prin1) ) (setq LAST_DIMSTYLE (cdr (assoc 2 (tblnext "DIMSTYLE" T)))) (defun change_dimension_style(/ ss ns ndx e ed) (prompt "\nSelect dimension entities: ") (setq ss (ssget '((0 . "DIMENSION")))) (setq ns (strcase (getstring (strcat "\nNew dimension style <" LAST_DIMSTYLE ">: ")))) (if (equal ns "") (setq ns LAST_DIMSTYLE) ) (setq LAST_DIMSTYLE ns) (if (not (tblsearch "DIMSTYLE" ns)) (progn (prompt "\nError: Must select existing dimension style.") (exit) ) ) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx) ed (entget e) ed (subst (cons 3 ns) (assoc 3 ed) ed) ) (entmod ed) (entupd e) ) ) (defun c:cts() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (change_text_style) (command ".undo" "end") (sysvarrestore) (prin1) ) (setq LAST_TEXTSTYLE (cdr (assoc 2 (tblnext "STYLE" T)))) (defun change_text_style(/ ss ns ndx e ed) (prompt "\nSelect text, or attdef entities: ") ; (setq ss (ssget '((-4 . "")))) (setq ss (ssget '((-4 . "")))) (setq ns (strcase (getstring (strcat "\nNew text style <" LAST_TEXTSTYLE ">: ")))) (if (equal ns "") (setq ns LAST_TEXTSTYLE) ) (setq LAST_TEXTSTYLE ns) (if (not (tblsearch "STYLE" ns)) (progn (prompt "\nError: Must select existing text style.") (exit) ) ) (command ".textstyle" ns) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx) ed (entget e) et (cdr (assoc 0 ed)) ) (if (or (equal et "TEXT") (equal et "ATTDEF")) (progn (setq ed (subst (cons 7 ns) (assoc 7 ed) ed)) (entmod ed) (entupd e) ) ; (progn ; (setq ed (remove (assoc -1 ed) ed)) ; (setq ed (remove (assoc 5 ed) ed)) ; (setq ed (remove (assoc 2 ed) ed)) ; (entdel e) ; (entmake ed) ; ) ) ) ) ; Change a fixed_width delimited string to a list ; e.g. (setq lst (fw_to_list l '((1 6) (7 8) (15 50) (65 1) (66 1)))) (defun fw_to_list (string def_list / lst def item) (setq lst '()) (foreach def def_list (setq item (substr string (car def) (cadr def))) (setq lst (append lst (list item))) ) lst ) ; Same as 'nth' function in Autolisp, only for strings. (defun c_nth (n string) (if (and (< n (strlen string)) (equal (type n) 'INT) (equal n (abs n))) (substr string (1+ n) 1) nil ) ) ;--------------------------------------------------------------begin C:BEAM---- (defun c:beam() (sysvarinit '("cmdecho" "blipmode")) (command ".undo" "group") (draw_beam) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun draw_beam (/ ww fw bd bw hbw ins p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12) (initget (+ 1 2 4)) (setq bd (getdist "\nBeam depth: ")) (initget (+ 1 2 4)) (setq ww (getdist "\nWeb Thickness: ")) (initget (+ 1 2 4)) (setq bw (getdist "\nFlange width: ")) (initget (+ 1 2 4)) (setq fw (getdist "\nFlange thickness: ")) (setq hbw (/ (- bw ww) 2.0)) (setq ins (getpoint "\nBeam center point: ")) (setq p1 (addy ins (- 0.0 (/ bd 2.0))) p1 (addx p1 (- 0.0 (/ bw 2.0))) p2 (addx p1 bw) p3 (addy p2 fw) p4 (addx p3 (- 0.0 hbw)) p5 (addy p4 (- bd (* fw 2.0))) p6 (addx p5 hbw) p7 (addy p6 fw) p8 (addx p7 (- 0.0 bw)) p9 (addy p8 (- 0.0 fw)) p10 (addx p9 hbw) p11 (addy p10 (- 0.0 (- bd (* fw 2.0)))) p12 (addx p11 (- 0.0 hbw)) ) (command ".pline" p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 "C") ) (defun addx (pt x) (mapcar '+ (list x 0 0) pt)) (defun addy (pt y) (mapcar '+ (list 0 y 0) pt)) (defun addz (pt z) (mapcar '+ (list 0 0 z) pt)) ;----------------------------------------------------------------end C:BEAM---- (defun c:asdf() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (asdf) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun asdf (/ ss ndx e) (prompt "\nRedraw entities...") (setq ss (ssget)) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (command ".copy" e "" "0,0,0" "") (entdel e) ) (command ".redraw") ) (defun bit_check (chk num_list) ;; num_list is a list of unique numbers ;; which are all powers of 2. bit_check ;; will return T if the bit value of any ;; of those numbers is on in chk. (not (equal 0 (logand chk (eval (cons 'logior num_list))))) ) ;---------------------------------------------------------------begin C:CLC---- (defun c:clc() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (change_layer_color) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun change_layer_color (/ data lay ld col ncol) (prompt "\nSelect entity to change its layer's color... ") (setq data (find_entity_data)) (setq lay (cadddr data)) (setq ld (tblsearch "LAYER" lay)) (setq col (cdr (assoc 62 ld))) (initget (+ 2 4)) (setq ncol (getint (strcat "\nNew color for layer " lay " <" (itoa col) ">: "))) (if (not (equal ncol '())) (command ".layer" "color" ncol lay "") ) ) ;-----------------------------------------------------------------end C:CLC---- ;---------------------------------------------------------------begin C:CLL---- (defun c:cll() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (change_layer_linetype) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun change_layer_linetype (/ data lay ld lt) (prompt "\nSelect entity to change its layer's linetype... ") (setq data (find_entity_data)) (setq lay (cadddr data)) (setq ld (tblsearch "LAYER" lay)) (setq lt (cdr (assoc 6 ld))) ;layer linetype (setq lt (getstring (strcat "\nNew linetype for layer " lay " <" lt ">: "))) (if (not (equal lt "")) (command ".layer" "ltype" lt lay "") ) ) ;-----------------------------------------------------------------end C:CLL---- ;----------------------------------------------------------------begin C:DI---- (defun c:din() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (draw_insulation) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun draw_insulation (/ pt1 pt2 xscale height num yscale) (setq pt1 (getpoint "\nLower left corner: ")) (setq pt2 (getcorner pt1 "\nUpper right corner: ")) (setq xscale (abs (- (car pt2) (car pt1)))) (setq height (abs (- (cadr pt2) (cadr pt1)))) (setq num (1+ (fix (/ height xscale)))) (setq yscale (/ height num)) (command ".insert" "ins_unit" pt1 xscale yscale "") (command ".array" (entlast) "" "rec" num "1" yscale) ) ;------------------------------------------------------------------end C:DI---- ;----------------------------------------------------------------begin C:DB---- (defun c:div() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (divide_w_lines) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun divide_w_lines (/ pt1 pt2 xscale height num yscale) (setq pt1 (getpoint "\nLower left corner: ")) (setq pt2 (getcorner pt1 "\nUpper right corner: ")) (setq lp1 pt1 lp2 (list (car pt2) (cadr pt1) (caddr pt1))) (setq xscale (getdist "\nApproximate line spacing: ")) ; (setq xscale (/ 8.0 3.0)) ; draw about 3 lines per 8 units (setq height (abs (- (cadr pt2) (cadr pt1)))) (setq num (1+ (fix (/ height xscale)))) (setq yscale (/ height (1- num))) (command ".line" lp1 lp2 "") (command ".array" (entlast) "" "rec" num "1" yscale) ) ;------------------------------------------------------------------end C:DB---- (defun c:wdd2 () (sysvarinit '("cmdecho")) (write_drawing_data2) (sysvarrestore) (prin1) ) (defun write_drawing_data2 () (wd_xrefs) (wd_layers) (wd_styles) ) (defun wd_xrefs (/ dwg dwgpre fname xrefs x data) (setq dwg (strcase (path_strip (getvar "DWGNAME")))) (setq dwgpre (getvar "DWGPREFIX")) (setq fname (strcat dwgpre "xrefdata.csv")) (setq xrefs (list_xrefs_full)) (setq data '()) (foreach x xrefs (setq data (cons (list dwg (car x) (cadr x)) data)) ) (append_cdf data fname) ) (defun wd_layers (/ dwgpre fname ldl) (setq dwgpre (getvar "DWGPREFIX")) (setq fname (strcat dwgpre "layrdata.csv")) (setq ldl (list_native_layer_data)) (append_cdf ldl fname) ) (defun wd_styles (/ dwgpre fname sdl) (setq dwgpre (getvar "DWGPREFIX")) (setq fname (strcat dwgpre "styldata.csv")) (setq sdl (list_native_styles)) (append_cdf sdl fname) ) (defun list_native_styles (/ dwg sdl sd sn fn) (setq dwg (path_strip (getvar "DWGNAME"))) (setq sdl '()) (setq sd (tblnext "STYLE" 1)) (while sd (setq sn (strcase (cdr (assoc 2 sd)))) (setq snt (strip_xref_name sn)) (if (equal sn snt) (progn (setq fn (strcase (cdr (assoc 3 sd)))) (setq fn (path_strip fn)) (setq sdl (cons (list dwg sn fn) sdl)) ) ) (setq sd (tblnext "STYLE")) ) sdl ) ;-----------------------------------------------------------------begin WDD---- (defun c:wdd (/ dwgname fname) (sysvarinit '("cmdecho")) (write_drawing_data) (sysvarrestore) (prin1) ) (defun write_drawing_data () (write_drawing_time) (write_drawing_xrefs) (write_drawing_layers) ) (defun write_drawing_time (/ dwgpre fname data) (setq dwgpre (getvar "DWGPREFIX")) (setq fname (strcat dwgpre "projdat1.cdf")) (if (findfile fname) (setq data (read_cdf_s2 fname)) (setq data '()) ) (setq data (update_time_data data)) (write_cdf data fname) ) (defun write_drawing_xrefs (/ dwgpre fname data) (setq dwgpre (getvar "DWGPREFIX")) (setq fname (strcat dwgpre "projdat2.cdf")) (if (findfile fname) (setq data (read_cdf_s2 fname)) (setq data '()) ) (setq data (update_xref_data data)) (write_cdf data fname) ) (defun write_drawing_layers (/ dwgpre fname data) (setq dwgpre (getvar "DWGPREFIX")) (setq fname (strcat dwgpre "projdat3.cdf")) (if (findfile fname) (setq data (read_cdf_s2 fname)) (setq data '()) ) (setq data (update_layer_data data)) (write_cdf data fname) ) (defun update_time_data (data / dwg nd) (setq dwg (path_strip (getvar "DWGNAME"))) (setq nd (list dwg (rtos (hindwg) 2 6))) (replace_or_insert nd data) ) (defun update_xref_data (data / dwg item xrefs x) (setq dwg (path_strip (getvar "DWGNAME"))) (while (setq item (assoc dwg data)) (setq data (remove item data)) ) (setq xrefs (list_xrefs)) (foreach x xrefs (setq data (cons (list dwg x) data)) ) data ) (defun update_layer_data (data / dwg item layers l) (setq dwg (path_strip (getvar "DWGNAME"))) (while (setq item (assoc dwg data)) (setq data (remove item data)) ) (setq layers (list_native_layers)) (foreach l layers (setq data (cons (list dwg l) data)) ) data ) (defun hindwg (/ td hours) (setq td (getvar "TDINDWG")) (setq hours (* 24.0 (- td (fix td)))) ) (defun list_xrefs (/ bl b bn tf) (setq bl '()) (setq b (tblnext "BLOCK" 1)) (while b (setq tf (cdr (assoc 70 b))) (if (and (bit_check tf (list 4)) (bit_check tf (list 32))); referenced xref (progn (setq bn (cdr (assoc 2 b))) (setq bl (cons bn bl)) ) ) (setq b (tblnext "BLOCK")) ) ; (setq bl (sort_strings bl)) bl ) (defun list_xrefs_notfound (/ bl b bn tf) (setq bl '()) (setq b (tblnext "BLOCK" 1)) (while b (setq tf (cdr (assoc 70 b))) (if (and (bit_check tf (list 4)) ; is an xref (not (bit_check tf (list 32)))); unresolved xref (progn (setq bn (cdr (assoc 1 b))) (setq bl (cons bn bl)) ) ) (setq b (tblnext "BLOCK")) ) ; (setq bl (sort_strings bl)) bl ) (defun list_xrefs_full (/ bl b bn tf bt) (setq bl '()) (setq b (tblnext "BLOCK" 1)) (while b (setq tf (cdr (assoc 70 b))) (if (and (bit_check tf (list 4)) ; is an xref (bit_check tf (list 32))); resolved xref (progn (if (bit_check tf (list 8)) (setq bt "overlay") (setq bt "attachment") ) (setq bn (cdr (assoc 1 b))) (setq bl (cons (list bn bt) bl)) ) ) (setq b (tblnext "BLOCK")) ) ; (setq bl (sort_strings bl)) bl ) (defun list_all_xrefs (/ bl b bn tf) (setq bl '()) (setq b (tblnext "BLOCK" 1)) (while b (setq tf (cdr (assoc 70 b))) (if (bit_check tf (list 4)); xref (progn (setq bn (cdr (assoc 2 b))) (setq bl (cons bn bl)) ) ) (setq b (tblnext "BLOCK")) ) bl ) (defun list_xrefs_as_string (/ xl xls) (setq xl (list_xrefs)) (setq xls "") (if xl (progn (setq xls (car xl)) (setq xl (cdr xl)) (while xl (setq xls (strcat xls " " (car xl))) (setq xl (cdr xl)) ) ) ) xls ) (defun list_layers (/ ll l ln) (setq ll '()) (setq l (tblnext "LAYER" 1)) (while l (setq ln (cdr (assoc 2 l))) (setq ll (cons ln ll)) (setq l (tblnext "LAYER")) ) ll ) (defun list_native_layers (/ ll l ln) (setq ll '()) (setq l (tblnext "LAYER" 1)) (while l (setq ln (cdr (assoc 2 l))) (setq lns (strip_layer_name ln)) (if (equal ln lns) (setq ll (cons ln ll)) ) (setq l (tblnext "LAYER")) ) ll ) (defun list_native_layer_data (/ dwg ll l ln lc lt ld) (setq dwg (strcase (path_strip (getvar "DWGNAME")))) (setq ll '()) (setq l (tblnext "LAYER" 1)) (while l (setq ln (cdr (assoc 2 l))) (setq lns (strip_layer_name ln)) (if (equal ln lns) (if (layer_used ln) (progn (setq lc (itoa (cdr (assoc 62 l)))) (setq lt (cdr (assoc 6 l))) (setq ld (list dwg ln lc lt)) (setq ll (cons ld ll)) ) ) ) (setq l (tblnext "LAYER")) ) ll ) (defun layer_used (ln / ss) (setq ss (ssget "x" (list (cons 8 ln)))) (if ss T '()) ) (defun strip_xref_name (name) (strip_layer_name name) ) (defun strip_layer_name (name / len new_name c) (setq len (1+ (strlen name))) (setq new_name "") (while (> (setq len (1- len)) 0) (setq c (substr name len 1)) (if (and (not (= c "$")) (not (= c "|"))) (setq new_name (strcat c new_name)) (setq len 0) ) ) new_name ) (defun replace_or_insert (item lst) (if (assoc (car item) lst) (subst item (assoc (car item) lst) lst) (cons item lst) ) ) (defun write_cdf (data fname / f l) (setq f (open fname "w")) (foreach l data (write-line (make_cdf l) f) ) (close f) ) (defun append_cdf (data fname / f l) (setq f (open fname "a")) (foreach l data (write-line (make_cdf l) f) ) (close f) ) ; return list starting with last occurance of item (defun member_last (item alist) (if (member item (cdr (member item alist))) (member_last item (cdr (member item alist))) (member item alist) ) ) ; Remove an item from a list. (defun remove (item alist / rev begin end) (if (member item alist) (progn (setq rev (reverse alist)) (setq begin (reverse (cdr (member_last item rev)))) (setq end (cdr (member item alist))) (if begin (if end (append begin end) begin ) (if end end nil ) ) ) alist ) ) ;-------------------------------------------------------------------end WDD---- ;------------------------------------------------------begin WRITE_DWG_DATA---- (defun c:write_dwg_data (/ dwgname fname) (sysvarinit '("cmdecho")) (setq dwgname (getvar "DWGNAME")) (setq fname (strcat dwgname ".log")) (write_tindwg fname) (sysvarrestore) (prin1) ) (defun write_layers (fname / f layer_data dwgname name col ltp str) (setq f (open fname "a")) (setq layer_data (tblnext "LAYER" T)) (setq dwgname (getvar "DWGNAME")) (setq dwgname (path_strip dwgname)) (while layer_data (setq name (cdr (assoc 2 layer_data))) (setq col (itoa (cdr (assoc 62 layer_data)))) (setq ltp (cdr (assoc 6 layer_data))) (setq str (strcat "\"" dwgname "\",\"" name "\",\"" col "\",\"" ltp "\"")) (write-line str f) (setq layer_data (tblnext "LAYER")) ) (close f) ) (defun write_tindwg (fname / td dname dv year month day hour minute tindwg_str date_string time_string tot_str) (setq td (tindwg)) (setq dname (getvar "DWGNAME")) (setq dname (path_strip dname)) (setq dv (rtos (getvar "cdate") 2)) (setq year (substr dv 1 4) month (substr dv 5 2) day (substr dv 7 2) hour (substr dv 10 2) minute (substr dv 12 2) ) (setq tindwg_str (strcat (itoa (car td)) ":" (itoa (cadr td)) ":" (itoa (caddr td)))) (setq date_string (strcat month "/" day "/" year)) (setq time_string (strcat hour ":" minute ":00")) (setq tot_str (strcat "\"" dname "\",\"" date_string "\",\"" time_string "\",\"" tindwg_str "\"")) (prompt (strcat "\n" tot_str)) (write_to_file fname tot_str) (prin1) ) (defun tindwg (/ td tseconds tminutes hours minutes seconds) (setq td (getvar "TDINDWG")) (setq tseconds (* 86400.0 (- td (fix td)))) (setq tminutes (* 1440.0 (- td (fix td)))) (setq hours (fix (* 24 (- td (fix td))))) (setq minutes (fix (- tminutes (* hours 60.0)))) (setq seconds (fix (- tseconds (* (fix tminutes) 60.0)))) (setq hours (+ hours (* 24 (fix td)))) (list hours minutes seconds) ) (defun appd_to_file (fname str) (setq f (open fname "a")) (write-line str f) (close f) (prin1) ) (defun write_to_file (fname str) (setq f (open fname "w")) (write-line str f) (close f) (prin1) ) ;--------------------------------------------------------end WRITE_DWG_DATA---- ;----------------------------------------------------------------begin C:BB---- (defun c:bb() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (bb) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun bb (/ ent pt) (setq ent (entsel "\nEntity to break: ")) (setq pt (getpoint "\nPoint to break at: ")) (command ".break" ent "F" pt pt) ) ;------------------------------------------------------------------end C:BB---- ;---------------------------------------------------------------begin C:BST---- (defun c:bst() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (block_select_tag) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun block_select_tag (/ ssf tag tagv ss ndx be ba ts) (setq ssf (ssadd)) (setq tag (getstring "\nTAG to select: ")) (setq tagv (getstring "\nTAG VALUE to select: ")) (prompt "\nSelect blocks to search: ") (setq ss (ssget '((0 . "INSERT")))) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq be (ssname ss ndx)) (setq ba (get_att2 be)) (if (assoc tag ba) (progn (setq ts (assoc tag ba)) (if (equal (cdr ts) tagv) (ssadd be ssf) ) ) ) ) (prompt (strcat "\n" (itoa (1- (sslength ssf))) " blocks with " (strcase tag) " = " (strcase tagv) " added to \"previous\" selection set.")) (command ".select" ssf "") (setq ssf '() ss '()) ) ;-----------------------------------------------------------------end C:BST---- ;---------------------------------------------------------------begin C:BSS---- (defun c:bss() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (block_select_some) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun block_select_some(/ bnames ssfilt ss len) (prompt "\nSelect blocks for selection filter...") (setq bnames (get_bnames)) (setq ssfilt '((-4 . "OR>"))) (while bnames (setq ssfilt (cons (cons 2 (car bnames)) ssfilt)) (setq bnames (cdr bnames)) ) (setq ssfilt (cons '(-4 . "")))) (setq ss (ssget sl)) (setq len (sslength ss)) (prompt (strcat "\n" (itoa len) " entities added to \"previous\" selection set.")) ) (prompt "\nNo layers selected.") ) ) ;-----------------------------------------------------------------end C:LSS---- ;----------------------------------------------------------------begin C:LS---- (defun c:ls() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (layer_select) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun layer_select(/ e ed lay) (prompt "\nSelect entity to build selection set based on layer: ") (setq e (car (entsel))) (setq ed (entget e)) (setq lay (cdr (assoc 8 ed))) (ssget "x" (list (cons 8 lay))) (prompt (strcat "\nUse \"previous\" to select all entities on layer " lay ".")) ) ;------------------------------------------------------------------end C:LS---- ;-----------------------------------------------------begin C:UPDATE_BLOCKS---- (defun c:ub () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (update_ablock) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun c:update_blocks () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (update_blocks) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun update_blocks (/ bd) (setq bd (tblnext "BLOCK" T)) (update_block bd) (while (setq bd (tblnext "BLOCK")) (update_block bd) ) ) (defun update_ablock (/ e ed bname bd flags) (setq e (car (entsel "\nSelect block to update"))) (setq ed (entget e)) (setq bname (cdr (assoc 2 ed))) (setq bd (tblsearch "BLOCK" bname)) (setq flags (cdr (assoc 70 bd))) (if (not (bit_check flags '(4))) ; not an xref (if (not (bit_check flags '(1))) ; not an anonymous block (if (findfile (strcat bname ".dwg")) (progn (command ".insert" (strcat "j:\\bpa\\dwg\\" bname) "0,0") (command) (prompt (strcat "\nUpdated block " bname ".")) ) (prompt (strcat "\nExternal definition of block " bname " not found.")) ) (prompt "\n" bname " is an anonymous block.") ) (prompt (strcat "\nBlock " bname " is an xref.")) ) (command ".regen") ) (defun update_block (bd / bname val) (setq bname (cdr (assoc 2 bd))) (setq flags (cdr (assoc 70 bd))) (if (not (bit_check flags '(4))) ; not an xref (if (bit_check flags '(64)) ; this definition is referenced (if (not (bit_check flags '(1))) ; not an anonymous block (if (findfile (strcat bname ".dwg")) (progn (initget 1 "Yes No") (setq val (getkword (strcat "\nUpdate block " bname " (Yes or No): "))) (if (equal val "Yes") (progn (command ".insert" (strcat "j:\\bpa\\dwg\\" bname) "0,0") (command) (prompt (strcat "\nUpdated block " bname ".")) ) ) ) (prompt (strcat "\nExternal definition of block " bname " not found.")) ) ; (prompt "\n" bname " is an anonymous block.") ) ; (prompt (strcat "\nBlock " bname " is not referenced.")) ) ; (prompt (strcat "\nBlock " bname " is an xref.")) ) ) ;-------------------------------------------------------end C:UPDATE_BLOCKS---- ;---------------------------------------------------------------begin C:CHH---- (defun c:chh() (change_height) ) (setq TEXT_HEIGHT 4.0) (defun change_height(/ ss ndx e ed new_height) (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (setq ss (ssget '((-4 . "")))) (if (not ss) (exit)) (setq new_height (getdist (strcat "\nNew height <" (rtos TEXT_HEIGHT) ">: "))) (if (equal new_height '()) (setq new_height TEXT_HEIGHT) ) (setq TEXT_HEIGHT new_height) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) (if (assoc 40 ed) (progn (setq ed (subst (cons 40 new_height) (assoc 40 ed) ed)) (entmod ed) (entupd e) ) ) ) (command ".undo" "end") (sysvarrestore) (prin1) ) ;-----------------------------------------------------------------end C:CHH---- ;----------------------------------------------------------------begin C:SB---- (defun c:sbs() (scale_block) ) (defun scale_blocks(/ ss ndx e ins sf) (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (setq ss (ssget '((0 . "INSERT")))) (if (not ss) (exit)) (setq sf (getdist "\nScale factor: ")) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) (setq ins (cdr (assoc 10 ed))) (command ".scale" e "" ins sf) ) (command ".undo" "end") (sysvarrestore) (prin1) ) ;------------------------------------------------------------------end C:SB---- ;-------------------------------------------------begin C:UPDATE_TITLEBLOCK---- (defun set_dwgname_tag (e / dname) (setq dname (strcat (getvar "DWGPREFIX") (getvar "DWGNAME"))) ; (setq dname (path_strip dname)) (setq dname (strcase dname)) (change_attrib_value e DWGNAMETAG dname) ) (defun set_date_tag (e / ed dv year month day hour minute et initials date_s) (setq ed (entget e)) (setq dv (rtos (getvar "cdate") 2)) (setq year (substr dv 1 4) month (substr dv 5 2) day (substr dv 7 2) hour (substr dv 10 2) minute (substr dv 12 2) initials (getenv "INITIAL") ) (if (< (strlen minute) 2) (setq minute (pad_string minute "0" (- 2 (strlen minute)))) ) ; (setq date_s (strcat month "/" day "/" year)) ; short format date (setq date_s (strcat month "/" day "/" year " " hour ":" minute)) ; long format date (if initials (setq date_string (strcat month "/" day "/" year " " hour ":" minute " " initials)) (setq date_string (strcat month "/" day "/" year " " hour ":" minute)) ) (change_attrib_value e DATETAG date_s) ) (defun set_xref_tag (e / xls) (setq xls (list_xrefs_as_string)) (change_attrib_value e XREFTAG xls) ) (defun set_drawn_by_tag (e / initials) (setq initials (getenv "INITIAL")) (if (not (or (equal initials "") (equal initials '()))) (change_attrib_value e DRAWNBYTAG (strcase initials)) ) ) (defun c:ut () (c:update_tb) ) (defun c:update_tb(/ tblock ss ndx e) (foreach tblock TBLOCKLST (setq ss (ssget "x" (list '(0 . "INSERT") (cons 2 tblock)))) (if ss (progn (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (progn (setq e (ssname ss ndx)) (set_dwgname_tag e) (set_date_tag e) (set_xref_tag e) ) ) ) ) ) ) ;---------------------------------------------------end C:UPDATE_TITLEBLOCK---- ;for TREN URBANO (defun c:cah() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (change_attribute_height) (command ".undo" "end") (sysvarrestore) (prin1) ) (setq CAH_BLIST '("*SEC_MARK" "*ELV_KEY" "*DET_KEY" "*SEC_TITL" "ZA_ELEV2")) (setq CAH_TAGS '("TAG" "A-TO201" "REF." "DWG#")) (setq CAH_SIZE 0.0024) (defun change_attribute_height(/ bnames ssfilt ss ndx be bd bn s e ed et) (setq bnames CAH_BLIST) (setq ssfilt '((-4 . "OR>"))) (while bnames (setq ssfilt (cons (cons 2 (car bnames)) ssfilt)) (setq bnames (cdr bnames)) ) (setq ssfilt (cons '(-4 . "= (setq ndx (1- ndx)) 0) (setq be (ssname ss ndx)) (setq bd (entget be)) (if (assoc 41 bd) (setq s (cdr (assoc 41 bd))) (setq s 1.0) ) (setq bn (cdr (assoc 2 bd))) (setq e (entnext be)) (setq ed (entget e)) (setq et (cdr (assoc 0 ed))) (while (not (equal et "SEQEND")) (if (equal et "ATTRIB") (if (and (member (cdr (assoc 2 ed)) CAH_TAGS) (equal (cdr (assoc 62 ed)) 2)) (progn (if (equal bn "ZA_ELEV2") (setq ed (subst (cons 40 (* 50 CAH_SIZE)) (assoc 40 ed) ed)) (setq ed (subst (cons 40 (* s CAH_SIZE)) (assoc 40 ed) ed)) ) (entmod ed) (entupd e) ) ) ) (setq e (entnext e)) (setq ed (entget e)) (setq et (cdr (assoc 0 ed))) ) ) ) ) ) (defun c:test(/ e ed et tag val typ) (prompt "\nPick block: ") (setq e (car (entsel))) (setq ed (entget e)) (while (not (equal (cdr (assoc 0 ed)) "SEQEND")) (setq et (cdr (assoc 0 ed))) (setq tag "" val "") (setq typ (cdr (assoc 0 ed))) (if (equal et "ATTRIB") (progn (setq tag (cdr (assoc 2 ed))) (setq val (cdr (assoc 1 ed))) ) ) (prompt (strcat "\n" typ "\t\t" tag "\t\t" val)) (setq e (entnext e)) (setq ed (entget e)) ) (prin1) ) (defun change_attrib_value (e tag value / ed et oldval) (setq ed (entget e)) (while (not (equal (cdr (assoc 0 ed)) "SEQEND")) (setq et (cdr (assoc 0 ed))) (if (equal et "ATTRIB") (if (equal (cdr (assoc 2 ed)) tag) (progn (if (setq oldval (assoc 1 ed)) (setq ed (subst (cons 1 value) oldval ed)) (setq ed (cons (cons 1 value) ed)) ) (entmod ed) (entupd e) ) ) ) (setq e (entnext e)) (setq ed (entget e)) ) ) (defun get_attrib_value (e tag / ed et val) (setq val '()) (setq ed (entget e)) (while (not (equal (cdr (assoc 0 ed)) "SEQEND")) (setq et (cdr (assoc 0 ed))) (if (equal et "ATTRIB") (if (equal (cdr (assoc 2 ed)) tag) (setq val (cdr (assoc 1 ed))) ) ) (setq e (entnext e)) (setq ed (entget e)) ) val ) (defun path_strip (name / len new_name c) (setq len (1+ (strlen name))) (setq new_name "") (while (> (setq len (1- len)) 0) (setq c (substr name len 1)) (if (not (or (= c "/") (= c "\\"))) (if (not (= c ".")) (setq new_name (strcat c new_name)) (setq new_name "") ) (setq len 0) ) ) new_name ) ;---------------------------------------------------------------begin C:CBD---- (defun c:cbd() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (copy_block_data) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun copy_block_data (/ be ss bdlist ndx) (setq be (get_block_ename)) (prompt "\nBlocks to copy data to...") (setq ss (ssget '((0 . "INSERT")))) (if ss (progn (setq bdlist (get_att2 be)) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq be (ssname ss ndx)) (add_bdata be bdlist) ) ) ) ) ;---------------------------------------------------------------begin C:CTV---- (defun c:ctv() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (change_tag_value) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun change_tag_value (/ ss tag val ndx e) (prompt "\nSelect entities to change attribute values for: ") (setq ss (ssget '((0 . "INSERT")))) (setq tag (getstring "\nTAG to change value for: ")) (setq tag (strcase tag)) (setq val (getstring "\nNew value: ")) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (change_attrib_value e tag val) ) ) ;-----------------------------------------------------------------end C:CTV---- ;----------------------------------------------------------------begin C:MM---- (defun c:mm (/ p1 p2) ; midpoint of two points (setq p1 (getpoint "\nPoint one: ")) (setq p2 (getpoint p1 "\nPoint two: ")) (get_midpoint p1 p2) ) (defun get_midpoint (p1 p2) (mapcar '(lambda (x) (/ x 2.0)) (mapcar '+ p1 p2)) ) ;------------------------------------------------------------------end C:MM---- ;----------------------------------------------------------------begin C:PO---- (defun c:po(/ e ed data lay tmp) (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (setq tmp (getvar "EXPERT")) (setvar "EXPERT" 5) (command ".undo" "group") ; (prompt "\nSelect entity to turn off its layer: ") ; (setq data (find_entity_data)) ; (setq lay (cadddr data)) ; (command ".layer" "off" lay "") ; (prompt (strcat "\nTurned off layer " (strcase lay) ".")) (pick_off) (command ".undo" "end") (setvar "EXPERT" tmp) (sysvarrestore) (prin1) ) (defun pick_off (/ ll data l) (save_state_layers 'LAYER_STATE) (prompt "\nSelect entities on layers you would like to turn off: ") (setq ll '()) (while (setq data (find_entity_data)) (setq l (cadddr data)) (if (not (member l ll)) (progn (setq ll (cons l ll)) (prompt (strcat "\nAdded layer " (strcase l))) ) (progn (setq ll (remove l ll)) (prompt (strcat "\nRemoved layer " (strcase l))) ) ) ) (if ll (progn (command ".layer") (foreach l ll (command "off" l) ) (command "") ) ) ) ;------------------------------------------------------------------end C:PO---- ;----------------------------------------------------------------begin C:LL---- (defun c:ll(/ e ed data lay tmp) (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (setq tmp (getvar "EXPERT")) (setvar "EXPERT" 5) (command ".undo" "group") (prompt "\nSelect entity to lock its layer: ") (setq data (find_entity_data)) (setq lay (cadddr data)) (command ".layer" "lock" lay "") (prompt (strcat "\nLocked layer " (strcase lay) ".")) (command ".undo" "end") (setvar "EXPERT" tmp) (sysvarrestore) (prin1) ) ;------------------------------------------------------------------end C:LL---- ;----------------------------------------------------------------begin C:LU---- (defun c:lu(/ e ed data lay tmp) (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (setq tmp (getvar "EXPERT")) (setvar "EXPERT" 5) (command ".undo" "group") (prompt "\nSelect entity to unlock its layer: ") (setq data (find_entity_data)) (setq lay (cadddr data)) (command ".layer" "unlock" lay "") (prompt (strcat "\nUnlocked layer " (strcase lay) ".")) (command ".undo" "end") (setvar "EXPERT" tmp) (sysvarrestore) (prin1) ) ;------------------------------------------------------------------end C:LU---- ;---------------------------------------------------------------begin C:PZV---- (defun c:pzv(/ data lay) (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") ; (prompt "\nSelect entity to freeze its layer in current viewport: ") ; (setq data (find_entity_data)) ; (setq lay (cadddr data)) ; (if (equal lay (getvar "CLAYER")) ; (prompt "\nCannot freeze current layer.") ; (progn ; (command ".vplayer" "freeze" lay "" "") ; (prompt (strcat "\nFroze layer " lay " in current viewport.")) ; ) ; ) (pick_freeze_viewport) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun pick_freeze_viewport (/ ll data l cl) (prompt "\nSelect entities on layers you would like to freeze in current viewport: ") (setq cl (getvar "CLAYER")) (setq ll '()) (while (setq data (find_entity_data)) (setq l (cadddr data)) (if (equal l cl) (prompt (strcat "\nCan't freeze current layer " (strcase l))) (if (not (member l ll)) (progn (setq ll (cons l ll)) (prompt (strcat "\nAdded layer " (strcase l))) ) (progn (setq ll (remove l ll)) (prompt (strcat "\nRemoved layer " (strcase l))) ) ) ) ) (if ll (progn (command ".vplayer") (foreach l ll (command "freeze" l "") ) (command "") ) ) ) ;-----------------------------------------------------------------end C:PZV---- ;----------------------------------------------------------------begin C:PZ---- (defun c:pfr () (c:pz) ) (defun c:pz(/ e data ed lay) (save_state_layers 'LAYER_STATE) (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") ; (prompt "\nSelect entity to freeze its layer: ") ; (setq data (find_entity_data)) ; (setq lay (cadddr data)) ; (if (equal lay (getvar "CLAYER")) ; (prompt "\nCannot freeze current layer.") ; (progn ; (command ".layer" "freeze" lay "") ; (prompt (strcat "\nFroze layer " (strcase lay) ".")) ; ) ; ) (pick_freeze) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun pick_freeze (/ ll data l cl) (prompt "\nSelect entities on layers you would like to freeze: ") (setq cl (getvar "CLAYER")) (setq ll '()) (while (setq data (find_entity_data)) (setq l (cadddr data)) (if (equal l cl) (prompt (strcat "\nCan't freeze current layer " (strcase l))) (if (not (member l ll)) (progn (setq ll (cons l ll)) (prompt (strcat "\nAdded layer " (strcase l))) ) (progn (setq ll (remove l ll)) (prompt (strcat "\nRemoved layer " (strcase l))) ) ) ) ) (if ll (progn (command ".layer") (foreach l ll (command "freeze" l) ) (command "") ) ) ) ;------------------------------------------------------------------end C:PZ---- ;--------------------------------------------------------------begin C:PSET---- (defun c:ys() (c:pset)) (defun c:pset(/ e ed lay) (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (prompt "\nSelect entity to make its layer current: ") (setq e (car (entsel))) (setq ed (entget e)) (setq lay (cdr (assoc 8 ed))) (command ".layer" "set" lay "") (prompt (strcat "\nCurrent layer set to " (strcase lay) ".")) (command ".undo" "end") (sysvarrestore) (prin1) ) ;----------------------------------------------------------------end C:PSET---- ;----------------------------------------------------------------begin C:GG---- (setq USER_LAYER1 "0") (defun c:gg1() (sysvarinit '("cmdecho" "blipmode" "osmode")) (command ".undo" "group") (gg1) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun gg1 (/ ss lay ndx ent ed) (setq ss (ssget)) (setq lay (getstring (strcat "\nLayer <" USER_LAYER1 ">: "))) (if (equal lay "") (setq lay USER_LAYER1) ) (setq USER_LAYER1 (strcase lay)) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq ent (ssname ss ndx)) (setq ed (entget ent)) (setq ed (subst (cons 8 lay) (assoc 8 ed) ed)) (entmod ed) (entupd ent) ) (prin1) ) (setq USER_LAYER2 "0") (defun c:gg2() (sysvarinit '("cmdecho" "blipmode" "osmode")) (command ".undo" "group") (gg2) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun gg2 (/ ss lay ndx ent ed) (setq ss (ssget)) (setq lay (getstring (strcat "\nLayer <" USER_LAYER2 ">: "))) (if (equal lay "") (setq lay USER_LAYER2) ) (setq USER_LAYER2 (strcase lay)) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq ent (ssname ss ndx)) (setq ed (entget ent)) (setq ed (subst (cons 8 lay) (assoc 8 ed) ed)) (entmod ed) (entupd ent) ) (prin1) ) (setq USER_LAYER3 "0") (defun c:gg3() (sysvarinit '("cmdecho" "blipmode" "osmode")) (command ".undo" "group") (gg3) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun gg3 (/ ss lay ndx ent ed) (setq ss (ssget)) (setq lay (getstring (strcat "\nLayer <" USER_LAYER3 ">: "))) (if (equal lay "") (setq lay USER_LAYER3) ) (setq USER_LAYER3 (strcase lay)) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq ent (ssname ss ndx)) (setq ed (entget ent)) (setq ed (subst (cons 8 lay) (assoc 8 ed) ed)) (entmod ed) (entupd ent) ) (prin1) ) ;------------------------------------------------------------------end C:GG---- ;----------------------------------------------------------------begin C:WD---- (setq USER_WIDTH 12.0) (defun c:wd() (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (rp_wall_double) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun rp_wall_double (/ e ed p1 p2 dir dir1 wid hw d1 d2) (setq e (car (entsel "\nPick line to double: "))) (setq ed (entget e)) (setq p1 (cdr (assoc 10 ed)) p2 (cdr (assoc 11 ed)) dir (mapcar '- p1 p2) dir1 (vec_z_rotate dir (/ pi 2.0)) ) (setq wid (getdist (strcat "\nWidth <" (rtos USER_WIDTH) ">: "))) (if (equal wid '()) (setq wid USER_WIDTH) ) (setq USER_WIDTH wid) (setq hw (/ USER_WIDTH 2.0)) (setq d1 (list 0 hw 0)) (setq d2 (list 0 (- 0 hw) 0)) (command ".ucs" "3point" p1 p2 (mapcar '+ p1 dir1)) (command ".copy" e "" d1 "") (command ".move" e "" d2 "") (command ".ucs" "prev") ) ;------------------------------------------------------------------end C:WD---- ;----------------------------------------------------------------begin C:QQ---- (defun c:qq (/ ent entdata e-type name lay col tble laycol) (setq ent (car (entsel))) (setq entdata (entget ent)) (setq e-type (cdr (assoc 0 entdata))) (if (equal e-type "INSERT") (progn (setq name (cdr (assoc 2 entdata))) (setq e-type (strcat e-type " \"" name "\"")) ) ) (setq lay (cdr (assoc 8 entdata))) (if (setq col (cdr (assoc 62 entdata))) (setq col (itoa col)) (progn (setq tble (tblsearch "LAYER" lay)) (setq laycol (cdr (assoc 62 tble))) (setq col (strcat "BYLAYER ")))) (prompt (strcat "\n" e-type " is color " col " and on layer " lay ".")) (prin1) ) ;------------------------------------------------------------------end C:QQ---- (defun find_entity_data (/ bs ent en ed et el ec elt ld lc ll) (setq bs '()) (setq ent (nentsel)) (if ent (progn (setq en (car ent)) ;Entity picked (setq ed (entget en)) ;Entity data (setq et (cdr (assoc 0 ed))) ;Entity type (setq el (cdr (assoc 8 ed))) ;Entity layer (setq ec (cdr (assoc 62 ed))) ;Entity color (if (or (equal ec '()) (equal ec 256)) (setq ec "BYLAYER") ) (if (equal ec 0) (setq ec "BYBLOCK")) (if (equal (type ec) 'INT) (setq ec (itoa ec))) (setq elt (cdr (assoc 6 ed))) ;Entity linetype (if (equal elt '()) (setq elt "BYLAYER") ) (if (= (length ent) 4) ;This is a block (setq bs (last ent)) ;Block list ) (setq el (find_entity_layer el bs)) ;First fixed layer (setq ld (tblsearch "LAYER" el) lc (itoa (cdr (assoc 62 ld)));Layer color ll (cdr (assoc 6 ld)) ;Layer linetype ) (list et ec elt el lc ll);Entity type, ;Entity color, ;Entity linetype, ;First fixed layer, ;Layer color, ;Layer linetype ) ) ) (defun find_entity_layer (el bs / b bd) (while (and (equal el "0") bs) (setq b (car bs)) (setq bd (entget b)) (setq el (cdr (assoc 8 bd))) (setq bs (cdr bs)) ) el ) ;---------------------------------------------------------------begin C:QQQ---- (defun c:qqq (/ data et ec elt el lc ll qs) (setq data (find_entity_data) et (car data) ec (cadr data) elt (caddr data) el (cadddr data) lc (car (cddddr data)) ll (last data) ) (setq qs (strcat "\nCOLOR: " ec "\t" "LINETYPE: " elt "\t" "TYPE: " et "\n" "COLOR: " lc "\t" "LINETYPE: " ll "\t" "LAYER: " el) ) (prompt qs) (prin1) ) ;-----------------------------------------------------------------end C:QQQ---- ;----------------------------------------------------------------begin C:CR---- (defun c:cr() (sysvarinit '("cmdecho" "blipmode" "osmode")) (command ".undo" "group") (cr) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun cr (/ e ss1 pt1 ss) (setq e (entlast)) (setq ss1 (ssget)) (setq pt1 (getpoint "\nFrom point: ")) (prompt "\nTo point: ") (command ".copy" ss1 "" pt1 pause) (setq ss (ssadd)) (setq e (if e (entnext e) (entnext))) (while e (setq ss (ssadd e ss)) (setq e (entnext e)) ) (prompt "\nRotation: ") (command ".rotate" ss "" (getvar "LASTPOINT") pause) ) ;----------------------------------------------------------------begin C:CC---- (setq USER_DIST_1 12.0) (setq USER_DIST_2 12.0) (setq USER_DIST_3 12.0) (defun c:cc1() (sysvarinit '("cmdecho" "blipmode" "osmode")) (command ".undo" "group") (cc1) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun cc1 (/ ents ctr ang dis b p1) ;; Function to multiply displace a ;; a selection set of entities. ;; Very useful for copying construction ;; drawings. (prompt "Select entities to multiply displace: ") (setq ents (ssget)) (setq ctr (getvar "VIEWCTR")) (setq ang (my_getangle ctr)) (setq dis USER_DIST_1) (setq b ctr) (while (or (equal dis ".") (equal dis "Direction") (equal (type dis) 'REAL)) (initget ". Direction") (setq dis (getdist (strcat "\nEnter distance <. for " (rtos USER_DIST_1) ", or Direction>: "))) (if (equal dis "Direction") (setq ang (my_getangle (getvar "viewctr"))) (progn (if (equal dis ".") (setq dis USER_DIST_1) ) (if (equal (type dis) 'REAL) (progn (setq USER_DIST_1 dis) (setq b (polar b ang dis)) (command ".copy" ents "" ctr b) ) ) ) ) ) (prin1) ) (defun c:cc2() (sysvarinit '("cmdecho" "blipmode" "osmode")) (command ".undo" "group") (cc2) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun cc2 (/ ents ctr ang dis b p1) ;; Function to multiply displace a ;; a selection set of entities. ;; Very useful for copying construction ;; drawings. (prompt "Select entities to multiply displace: ") (setq ents (ssget)) (setq ctr (getvar "VIEWCTR")) (setq ang (my_getangle ctr)) (setq dis USER_DIST_2) (setq b ctr) (while (or (equal dis ".") (equal dis "Direction") (equal (type dis) 'REAL)) (initget ". Direction") (setq dis (getdist (strcat "\nEnter distance <. for " (rtos USER_DIST_2) ", or Direction>: "))) (if (equal dis "Direction") (setq ang (my_getangle (getvar "viewctr"))) (progn (if (equal dis ".") (setq dis USER_DIST_2) ) (if (equal (type dis) 'REAL) (progn (setq USER_DIST_2 dis) (setq b (polar b ang dis)) (command ".copy" ents "" ctr b) ) ) ) ) ) (prin1) ) (defun c:cc3() (sysvarinit '("cmdecho" "blipmode" "osmode")) (command ".undo" "group") (cc3) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun cc3 (/ ents ctr ang dis b p1) ;; Function to multiply displace a ;; a selection set of entities. ;; Very useful for copying construction ;; drawings. (prompt "Select entities to multiply displace: ") (setq ents (ssget)) (setq ctr (getvar "VIEWCTR")) (setq ang (my_getangle ctr)) (setq dis USER_DIST_3) (setq b ctr) (while (or (equal dis ".") (equal dis "Direction") (equal (type dis) 'REAL)) (initget ". Direction") (setq dis (getdist (strcat "\nEnter distance <. for " (rtos USER_DIST_3) ", or Direction>: "))) (if (equal dis "Direction") (setq ang (my_getangle (getvar "viewctr"))) (progn (if (equal dis ".") (setq dis USER_DIST_3) ) (if (equal (type dis) 'REAL) (progn (setq USER_DIST_3 dis) (setq b (polar b ang dis)) (command ".copy" ents "" ctr b) ) ) ) ) ) (prin1) ) ;------------------------------------------------------------------end C:CC---- ;----------------------------------------------------------------begin C:WW---- (defun c:ww (/ scmde omode l line1 line2 pt1 pt2 dis dx dy ang) (setq omode (getvar "osmode")) (setvar "osmode" 0) (setq l nil) (while (not (setq l (entsel "\nPick first line: "))) (prompt "\nYou selected nothing, try again...") ) (setq line1 (car l)) (while (/= (cdr (assoc 0 (entget line1))) "LINE") (prompt "\nMust select a LINE entity.") (setq l nil) (while (not (setq l (entsel "\nPick first line: "))) (prompt "\nYou selected nothing, try again...") ) (setq line1 (car l)) ) (setq l nil) (while (not (setq l (entsel "\nPick second line: "))) (prompt "\nYou selected nothing, try again...") ) (setq line2 (car l)) (while (/= (cdr (assoc 0 (entget line2))) "LINE") (prompt "\nMust select a LINE entity.") (setq l nil) (while (not (setq l (entsel "\nPick second line: "))) (prompt "\nYou selected nothing, try again...") ) (setq line2 (car l)) ) (setq pt1 (cdr (assoc 10 (entget line1)))) (setq pt2 (cdr (assoc 11 (entget line2)))) (setq pt1 (trans pt1 0 1)) (setq pt2 (trans pt2 0 1)) (setq dis (rtos (distance pt1 pt2))) (setq dx (rtos (abs (- (car pt1) (car pt2))))) (setq dy (rtos (abs (- (cadr pt1) (cadr pt2))))) (setq ang (angtos (angle pt1 pt2))) (prompt (strcat "\nDistance: " dis ", Angle in XY plane: " ang ", Delta X: " dx ", Delta Y: " dy)) (setvar "osmode" omode) (prin1) ) ;------------------------------------------------------------------end C:WW---- ;-------------------------------------------------------------begin C:ARROW---- (setq HEAD_LENGTH 12.0) (defun c:arrow () (sysvarinit '("cmdecho" "blipmode" "osmode" "orthomode")) (command ".undo" "group") (draw_arrow) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun draw_arrow (/ pt1 pt2 v hp) (initget 1) (setq pt1 (getpoint "\nFirst point: ")) (initget 1) (setq pt2 (getpoint pt1 "\nSecond point: ")) (setq v (caadr (vec_normal_scale (list (mapcar '- pt1 pt2))))) (setq v (list (* HEAD_LENGTH (car v)) (* HEAD_LENGTH (cadr v)) (* HEAD_LENGTH (caddr v)))) (setq hp (mapcar '+ v pt2)) (command ".pline" pt1 hp "w" (* 0.75 HEAD_LENGTH) 0.0 pt2 "") ) ;---------------------------------------------------------------end C:ARROW---- (defun sysvarinit (varlist / var state) ;; varlist like: ;; '("cmdecho" "blipmode" "osmode" "pdsize") (setq SYSVARSTATE nil) (foreach var varlist (setq state (getvar var)) (setq SYSVARSTATE (cons (list var state) SYSVARSTATE)) (eval (list 'setvar var 0)) ) ) (defun sysvarrestore (/ item) (foreach item SYSVARSTATE (eval (cons 'setvar item)) ) ) (defun my_getangle (p / ang) (initget 1 "Reference") (setq ang (getangle p "\nDisplacement direction : ")) (if (= ang "Reference") (progn (initget 1) (setq p (getpoint "\nFirst point: ")) (initget 1) (setq ang (getangle p "\nSecond point: ")) ) ) ang ) (defun get_layer (pmt / lay) (setq lay (getstring pmt)) (while ( and (not (tblsearch "LAYER" lay)) (not (equal lay ""))) (progn (prompt (strcat "\nLayer " (strcase lay) " does not exist, try again...")) (setq lay (getstring pmt)) ) ) (if lay (strcase lay) nil) ) (defun get_layers (/ ll ss ndx e ed lay) (prompt "\nSelect entities to create layer list...") (setq ll '()) (setq ss (ssget)) (setq ndx (sslength ss)) (while (>= (setq ndx (1- ndx)) 0) (setq e (ssname ss ndx)) (setq ed (entget e)) (setq lay (cdr (assoc 8 ed))) (if (and (not (member lay ll)) (not (equal lay "0")) (not (equal lay "DEFPOINTS"))) (setq ll (cons lay ll)) ) ) (setq ll (sort_strings ll)) (show_strings ll) ll ) (defun make_vertex_pt_list (e / v_list e ed gp) (setq v_list '()) (setq ed (entget e)) (setq et (cdr (assoc 0 ed))) (if (equal et "POLYLINE") ;ELSE IS A LWPOLYLINE (while (/= (cdr (assoc 0 (setq ed (entget (setq e (entnext e)))))) "SEQEND") (if (= (cdr (assoc 0 ed)) "VERTEX") (setq v_list (append v_list (list (cdr (assoc 10 ed))))) ) ) (foreach gp ed (if (equal (car gp) 10) (setq v_list (append v_list (list (cdr gp)))) ) ) ) v_list ) (defun old_make_buf_fence (pt1 pt2 wid / ang ang1 ang2 ang3 ang4) (setq ang (angle pt1 pt2) ang1 (- ang (/ PI 4.0)) ang2 (+ ang (/ PI 4.0)) ang (+ ang PI) ang3 (- ang (/ PI 4.0)) ang4 (+ ang (/ PI 4.)) ) (list (polar pt2 ang1 wid) (polar pt2 ang2 wid) (polar pt1 ang3 wid) (polar pt1 ang4 wid) ) ) ; Scale all vectors in a list by the same ratio required to scale ; the longest vector in the list to length 1. ; (defun vec_normal_scale (vec_list / len vec tmp scale ret_list) (setq len 0) (foreach vec vec_list (setq tmp (vector_length vec)) (if (> tmp len) (setq len tmp) ) ) (if (> len 0.0) (progn (setq scale (/ 1.0 len)) (foreach vec vec_list (setq vec (v_scale vec scale)) (setq ret_list (append ret_list (list vec))) ) (list scale ret_list) ) nil ) ) (defun vec_z_rotate (vec ang / ox oy x y z) ;; ang in radians (setq ox (car vec) oy (cadr vec)) (setq x (- (* ox (cos ang)) (* oy (sin ang))) y (+ (* ox (sin ang)) (* oy (cos ang))) ) (list x y (caddr vec)) ) (defun save_list_to_file (lst name / f) (setq f (open name "w")) (prin1 (list 'quote lst) f) (close f) ) (defun write_str_list (lst fname / f d item) (if (setq f (findfile fname)) (setq d (open f "w")) (setq d (open fname "w")) ) (foreach item lst (write-line item d) ) (close d) ) (defun write_lsp_file (lsp_list fil / f d) (if (setq f (findfile fil)) (setq d (open f "w")) (setq d (open fil "w")) ) (prin1 (list 'quote lsp_list) d) (close d) ) (defun c:cst () (sysvarinit '("cmdecho")) (command ".undo" "group") (clean_styles) (command ".undo" "end") (sysvarrestore) (prin1) ) (defun clean_styles(/ st) (prompt "\nRemoving font path prefixes for all text styles...") (setq st (tblnext "STYLE" 1)) (clean_style st) (while (setq st (tblnext "STYLE")) (clean_style st) ) ) ;Remove any specific path prefixes for fonts. (defun clean_style (st / nm pf bf f) (setq nm (cdr (assoc 2 st))) ; style name (setq pf (cdr (assoc 3 st))) ; primary font (setq bf (cdr (assoc 4 st))) ; big font (if (local_style nm) (progn (prompt (strcat "\nCleaning: " nm)) (setq pf (path_strip pf)) (setq bf (path_strip bf)) (if (not (equal bf "")) (setq f (strcat pf "," bf)) (setq f pf) ) (command ".style" nm f) (while (> (getvar "CMDACTIVE") 0) (command "") ) ) ) ) (defun local_style (nm) (not (char_in_string "|" nm)) ) (defun char_in_string (c s / i ret l) (setq i 0) (setq ret '()) (setq l (strlen s)) (while (and (< i l) (equal ret '())) (setq tc (c_nth i s)) (if (equal tc c) (setq ret T) ) (setq i (1+ i)) ) ret ) ;INITIALIZATION---------------------------------------------------------------- ;------------------------------------------------------------------------------ (defun c:setup() (sysvarinit '("cmdecho")) (command ".insert" "setup=j:\\lisp\\acad" "0,0" "" "" "") (command ".erase" (ssget "x" '((0 . "INSERT") (2 . "SETUP"))) "" ) (sysvarrestore) (prin1) ) (setq SCALES '((1.0 "1\"=1\"") (2.0 "6\"=1'-0\"") (4.0 "3\"=1'-0\"") (8.0 "1 1/2\"=1'-0\"") (12.0 "1\"=1'-0\"") (16.0 "3/4\"=1'-0\"") (24.0 "1/2\"=1'-0\"") (32.0 "3/8\"=1'-0\"") (48.0 "1/4\"=1'-0\"") (64.0 "3/16\"=1'-0\"") (96.0 "1/8\"=1'-0\"") (128.0 "3/32\"=1'-0\"") (192.0 "1/16\"=1'-0\"")) ) (setq CURRENT_SCALE 1.0) (defun set_scale () (setq CS_DIV (/ CURRENT_SCALE 1.0)) (setq CS_PROMPT (cadr (assoc CURRENT_SCALE SCALES))) ; (setvar "TEXTSIZE" (* (/ 3.0 32.0) CURRENT_SCALE)) ) (set_scale) (c:update_tb) (prompt MESS) (setq WFA_LOADED "YES") (prin1)


Last modified: Mon Feb 26 10:08:22 EST 2007