; All lisps were written by Brian Forbes - http://www.autolisp.org/ unless noted otherwise. ; To install, see: http://www.autolisp.org/install.htm ; To list the names of the installed lisps, put this file in the c:\ directory and type listlisp ; If you're missing anything or they give you an error, please tell me. ;Load Explorer Window in Current Directory: (DEFUN C:DIRR() ; By Brian Forbes - http://www.autolisp.org/ (STARTAPP "EXPLORER.EXE" (GETVAR "DWGPREFIX")) (princ)) ;Previous Objects to New Layer: (DEFUN C:p2n () ; Previous to New Layer - By Brian Forbes - http://www.autolisp.org/ (PROMPT "\nName of layer for entities to reside: ")(SETQ newlay (GETSTRING)) (COMMAND "LAYER" "N" newlay "" "CHANGE" "p" "" "P" "LA" newlay "" "CHANGE" "p" "" "P" "C" "BYLAYER" "")) ;Change Color: (DEFUN C:cxc (/ osm ln) ; Change the color of a layer by selecting an object - By Brian Forbes - http://www.autolisp.org/ (SETQ osm (getvar "osmode")) (SETVAR "osmode" 0) (SETQ ln (cdr (assoc 8 (entget (car (nentselp (getpoint "Select object: "))))))) (PROMPT "Select Color: ") (COMMAND "LAYER" "C" pause ln "") (SETVAR "osmode" osm) (PRINC)) ;Text: (DEFUN C:cf () ; Copy text [normally with snap modes enabled, this one is simplified] - By Brian Forbes - http://www.autolisp.org/ (PRINC (SETQ CT (CDR (ASSOC 1 (setq ed (entget (car (nentselp (getpoint "Select text to copy: "))))))))) (while T (c:yt)) (PRINC)) (DEFUN C:YT () ; Paste text - By Brian Forbes - http://www.autolisp.org/ (setq ed (entget (car (nentselp (getpoint "\nSelect text to replace: "))))) (entmod (subst (cons 1 CT) (assoc 1 ed) ed ) ) (ENTUPD (CDR (CAR ED))) ) ;Add Text to the End of a String (defun c:ate() ;; Add text to the end of a string - By Brian Forbes - http://www.autolisp.org/ (command "undo" "_be") ; (setq ui (getstring)) ; Use this to prompt for string and comment out the following line (setq ui " Your string here!") (setq ed (entget (car (nentselp (cadr (entsel)))))) (entmod (subst (cons 1 (strcat (cdr (assoc 1 ed)) (if (= (setq str ui) "") " " str) )) (assoc 1 ed) ed ) ) (ENTUPD (CDR (CAR ed))) (command "undo" "_end") (PRINC)) ;Add Points & Midpoint: (defun addpoints (p1 p2 / p3) ; adds 2 points together - By Brian Forbes - http://www.autolisp.org/ (setq p3 (list (+ (car p1) (car p2)) (+ (cadr p1) (cadr p2)) (+ (caddr p1) (caddr p2)) ))) (defun mp ( p1 p2 / p1x p1y p2x p2y ) ; Returns the point between two points - By Brian Forbes - http://www.autolisp.org/ (SETQ P1X (CAR p1))(SETQ P1Y (CADR p1)) (SETQ P2X (CAR p2))(SETQ P2Y (CADR p2)) (LIST (/ (+ P1X P2X) 2) (/ (+ P1Y P2Y) 2))) ;Open Next Drawing: (defun C:nd () ; next drawing - no save - by Brian Forbes - http://www.autolisp.org/ (setq dir (vl-directory-files (setq pre (getvar "dwgprefix")) "*.dwg"))(command "color" "bylayer") (setq dbm (getvar "dbmod")) (if (> (length (setq memb (member (getvar "dwgname") dir))) 1) (setq nxt (cadr memb))) ; (COMMAND "qsave") ; delete the ; at the front of the line to save the dwg by default (if nxt (if (= (getvar "sdi") 0) (command "._VBASTMT" (strcat "AcadApplication.Documents.Open \"" (strcat pre nxt) "\"")) (if (> dbm 0) (command "open" "yes" (strcat pre nxt)) (command "open" (strcat pre nxt))) ) ; if sdi ) ; if (if nxt (if (> dbm 0) (command "close" "yes") (command "close"))) ) ;Resize a line: (defun c:res () ; Resize a line - by Brian Forbes - http://www.autolisp.org/ (command "undo" "m") (setvar "osmode" 0) (setq op (getpoint "Select object to resize: ")) (while (not (setq obj (ssname (ssget op (list (cons 0 "LINE"))) 0)))(setq op (getpoint "Select line to resize: "))) (redraw obj 3) (setq newdist (getdist "New size: ")) (redraw obj 1) (setq p1 (cdr (assoc 10 (entget obj)))) (setq p2 (cdr (assoc 11 (entget obj)))) (if newdist (progn (if (< (distance p1 op) (distance p2 op)) (entmod (subst (cons 11 (polar p2 (angle p2 p1) (- (distance p1 p2) newdist))) (cons 11 p2) (entget obj))) (entmod (subst (cons 10 (polar p1 (angle p1 p2) (- (distance p1 p2) newdist))) (cons 10 p1) (entget obj))) ) (if lispscale (setq newdist (* newdist lispscale))) ) (progn (setq newdist (distance p1 p2)) (if lispscale (setq newdist (* newdist lispscale))) (redraw obj 4) )) ; if & progn (princ) ) ;Connect Two Lines With a Line: (DEFUN C:CW (/ POINT1 POINT2 POINT3 POINT4 P1 P2 SS LAY) ; - By Brian Forbes - http://www.autolisp.org/ (SETQ LAY (GETVAR "CLAYER")) (C:SETP) (SETQ SS (SSGET "P")) (SETQ POINT1 (CDR (ASSOC 10 (ENTGET (SSNAME SS 0)))) POINT2 (CDR (ASSOC 11 (ENTGET (SSNAME SS 0))))) (SETQ POINT3 (CDR (ASSOC 10 (ENTGET (SSNAME SS 1)))) POINT4 (CDR (ASSOC 11 (ENTGET (SSNAME SS 1))))) (IF (< (DISTANCE POINT1 (GETVAR "LASTPOINT")) (DISTANCE POINT2 (GETVAR "LASTPOINT"))) (SETQ P1 POINT1) (SETQ P1 POINT2)) (IF (< (DISTANCE POINT3 (GETVAR "LASTPOINT")) (DISTANCE POINT4 (GETVAR "LASTPOINT"))) (SETQ P2 POINT3) (SETQ P2 POINT4) ) (SETVAR "CLAYER" (cdr (assoc 8 (entget (SSNAME SS 0))))) (COMMAND "LINE" P1 P2 "") (SETVAR "CLAYER" LAY) ) ;Ddedit and Ddatte in one shot: (DEFUN C:ED() ;; Ddedit and Ddatte in one - By Brian Forbes - http://www.autolisp.org/ (C:SETL) (SETVAR "QTEXTMODE" 0) (setq ttype (CDR (ASSOC 0 (setq ent-l (ENTGET (setq ent (SSNAME (SSGET "L") 0))))))) (setq lp (getvar "lastpoint")) (if (setq lo (car (nentselp lp))) (if (= "ATTRIB" (CDR (ASSOC 0 (ENTGET lo)))) (setq ttype (CDR (ASSOC 0 (setq ent-l (ENTGET (setq ent lo))))))) ) ; if (if (> (strlen (getvar "dwgname")) 8) (setq sheetno (substr (getvar "dwgname") 5 (- (strlen (getvar "dwgname")) 8))) (setq sheetno "") ) ; if (cond ((OR (= "TEXT" ttype) (= "DIMENSION" ttype) (= "MTEXT" ttype) (= "ATTDEF" ttype)) (COMMAND "DDEDIT" "L" "") ) ; ddedit condition ((and (= "INSERT" ttype) (wcmatch (strcase (setq ent-n (cdr (assoc 2 ent-l)))) "XREF-TITLE-*") ) ; and (command "xref" "bind" ent-n "explode" "l" "" "purge" "B" ent-n "n") ; use ent-n because sheetno isn't always what is selcted - after a saveas, for instance... (setq ent (ssname (ssget "p") 0)) (setq mtextout T) ; we need to bind the xref, explode the block ) ; xref cond ((= ttype "ATTRIB") (command "undo" 3) ; this is the stupidest fix ever, but it works - undo the setl, then attipedit works! (command "attipedit" (getvar "lastpoint")) ) ; Try it first with a new copy of the object ((= ttype "RTEXT") (princ "Old text: ") (princ (cdr (assoc 1 (entget ent)))) (setq txt (getstring T "\nNew Text: ")) (princ (entmod (subst (cons 1 txt) (assoc 1 (entget ent)) (entget ent)))) (entupd ent) ) ; rtext cond (T (COMMAND "DDATTE" "L")) ) ; cond (princ) ) ;Set Last and Previous: (for the 2 previous functions) (DEFUN C:SETL() ; By Brian Forbes - http://www.autolisp.org/ (COMMAND "._SELECT" "_SI" "_AU" PAUSE "COPY" "P" "" "_non" "@0,0" "_non" "@0,0" "ERASE" "P" "") (princ)) (DEFUN C:SETP() ; By Brian Forbes - http://www.autolisp.org/ (COMMAND "._SELECT" "_SI" "_AU" PAUSE) (princ)) ;Move objects with selected attribute: (DEFUN C:mj ( / num obj obj2) ; Move Attribute - By Brian Forbes - http://www.autolisp.org/ (SETQ num (GETINT "Number of attribute: ")) (SETQ obj (CDR (ASSOC num (ENTGET (CAR (ENTSEL "\nSelect sample object to move: ")))))) (SETQ obj2 (SSGET "X" (LIST (CONS num obj)))) (COMMAND "MOVE" obj2 "") (princ)) ;| The Following is for use with mj [ssget] - print out and attach to monitor! The dxf help in vlisp is also a good source. -4 - Conditional operator -3 - Extended data sentinel -2 - Name 0 - Type 1 - Text 2 - Name, block name, attrib tag 3-4 - Misc. 6 - Ltype 7 - Text Style or attrib def. 8 - Layer 10 - Primary pt. 11-18 - Other pts. 39 - Thickness 40-48 - Block scale, text height, etc. 50-58 - Angles 62 - Color 66 - "Entities follow" 67 - Drawing space (0 ps, 1 ms) 70-78 - Integers for counters 210 - 3d 999 - Comments |; (defun c:mb ( / cme osm pt sample ss count count2 howmany cur) ; Match by one object the properties of many objects - by Brian Forbes - http://www.autolisp.org/ ; Similar to matchprop of autocad r14 ; The property must exist in the object for it to be considered for changing (eg. 62 - color) ; Use this one at your own risk! (setq osm (getvar "osmode")) (setvar "osmode" 0) (setq pt (getpoint "Match by: ")) (if (not (if pt (nentselp pt) nil)) (progn (princ "No object selected.") (setvar "osmode" osm)) (progn (setq sample (entget (car (nentselp pt)))) (setq ss (ssget)) (setq num (sslength ss) count 0 howmany 0) (setq cme (getvar "cmdecho")) (setvar "cmdecho" 0) (command "undo" "mark") (setvar "cmdecho" cme) (while (<= (setq count (1+ count)) num) (setq count2 0) (setq cur (entget (ssname ss (1- count)))) (while (< (setq count2 (1+ count2)) 76) (if (= count2 5) (setq count2 6)) ; Hex handle (if (= count2 10) (setq count2 37)) ; All points (if (= count2 41) (setq count2 44)) ; X, Y, & Z Scale (if (= count2 50) (setq count2 52)) ; Rotation Angle (if (car (assoc count2 sample)) (if (car (assoc count2 cur)) (progn (setq cur (subst (assoc count2 sample) (assoc count2 cur) cur)) )) ; if cur & progn ) ; if sample ) ; while count2 (if (entupd (cdr (assoc -1 (entmod cur)))) (setq howmany (1+ howmany))) ) ; while countf )) ; if & progn there is no point (setvar "osmode" osm) (princ) ) ; Z0 ; By Brian Forbes - http://www.autolisp.org/ ; Home of the custom built lisp! ; ; Permissions: ; Permission is hereby granted to copy and modify this lisp. It is provided "as is" by the author. ; The authorship and url must remain with the copied function. ; Version: ; 1.0 - Sept 20, 2002 ; 1.1 - Sept 20, 2002 - Fixed the need to repeat the command ; 1.2 - Oct. 8, 2002 - Added pline functionality, added header text ; Explanation: ; This function takes all selected objects and makes them two dimensional by putting all the objects' ; z coordinate on 0. ; Known bugs: ; none ; Function call: ; z0 on the command line ; (defun c:z0 () ; puts all selected objects z point on 0 - By Brian Forbes - http://www.autolisp.org/ (princ "Select objects: ") (setq ss (ssget) count (1- (sslength ss)) asno 9) (command "undo" "mark") (while (>= count 0) (setq curent (entget (ssname ss count))) (while (and (setq asno (1+ asno)) (< asno 19) (if (not (assoc asno curent)) (progn ; begin if polyline (setq asno 38) (if (assoc asno curent) (progn (entupd (cdr (assoc -1 (entmod (subst (cons asno 0.0) (assoc asno curent) curent ) )))) nil ) nil ) ) T ) ; if polyline ) (if (/= 0 (cadddr (assoc asno curent))) (entupd (cdr (assoc -1 (setq curent (entmod (subst (cons asno (list (cadr (assoc asno curent)) (caddr (assoc asno curent)) 0)) (assoc asno curent) curent ) ))))) ; entupd ) ; if ) ; while and (setq count (1- count) asno 9) ) ; while count (princ) ) ;List All Lisps in a Directory: (defun c:listlisp ( / sample count found dir files curfile input output curline continue eol n n2 eofcountdown) ; -------------------------------------------------------- ; listlisp v2 - by Brian Forbes - http://www.autolisp.org/ ; -------------------------------------------------------- (setq sample (getfiled "Select sample file: " "I:\\Standard\\lisp\\brian\\2002\\" "lsp" 8)) (setq count (strlen sample)) (while (and (> (setq count (1- count)) 0) (not found)) (if (= (substr sample count 1) "\\") (setq found count)) ) ; while (setq dir (substr sample 1 found)) (setq files (vl-directory-files dir)) (setq count (length files)) (while (>= (setq count (1- count)) 0) (setq curfile (nth count files)) (if (< (strlen curfile) 4) (setq files (vl-remove curfile files)) (if (not (= "LSP" (strcase (substr curfile (- (strlen curfile) 2) 3)))) (setq files (vl-remove curfile files)) ) ; if ) ; if ) ; while count (setq count (length files)) (setq output (open "c:\\lispout.txt" "w")) (while (>= (setq count (1- count)) 0) (setq input (open (findfile (strcat dir (nth count files))) "r")) (write-line (princ (nth count files)) output) (princ " - ") (setq curline (read-line input) continue T eol "1234567" n 1 n2 1) (while continue (if (not curline) (setq continue nil) (progn (while (and (= (strlen eol) 7) (/= (setq eol (strcase (substr curline n 7))) "(DEFUN ")) (setq n (+ 1 n) ) ) ; while not defun (if (= eol "(DEFUN ") (progn (setq n (+ n 7) n2 n) (while (and (/= (substr curline n2 1) " ") (/= (substr curline n2 1) "(") (/= (substr curline n2 1) "")) (setq n2 (+ n2 1)) ) (write-line (substr curline n (- n2 n)) output) )) ; if & progn defun (setq curline (read-line input) continue T eol "1234567" n 1 n2 1) ) ; progn curline ) ; if curline ) ; while continue (setq eofcountdown 30) (while (> eofcountdown 0) (setq curline (read-line input)) (if curline (setq continue T eofcountdown -1 eol "1234567" n 1 n2 1) (setq eofcountdown (- eofcountdown 1))) ) ; while (close input) ) ; while count (close output) (princ "Done!") (startapp "write" "c:\\lispout.txt") (princ) ) ; listlisp v2 (defun c:mb ( / cme osm pt sample tsample ss count howmany cur isblock blk entnextcount centnexts) ; Match by one object the properties of many objects - by Brian Forbes - http://www.autolisp.org/ ; Also known as Match Block ; Similar to matchprop of autocad r14 ; The property must exist in the object for it to be considered for changing (eg. 62 - color) (setq osm (getvar "osmode")) (setvar "osmode" 0) (setq pt (getpoint "Match by: ")) (if (not (if pt (nentselp pt) nil)) (c:mbprop) (progn (setq sample (entget (car (nentselp pt)))) ; the following is for use with blocks with attributes ------------------------------- (setq blk (ssname (ssget pt) 0)) (if blk (setq isblock (if (= (cdr (assoc 0 (entget blk))) "INSERT") T nil))) (if (and isblock (entnext blk)) (while (= (cdr (assoc 0 (entget (entnext blk)))) "ATTRIB") (setq blk (entnext blk) entnextcount (1+ (if entnextcount entnextcount 0))) ) ; while ) ; if isblock (setq blk (ssname (ssget pt) 0)) (if (/= (cdr (assoc 0 (entget blk))) "INSERT") (setq blk nil)) (if entnextcount (progn (princ " Attribute text detected: ") (princ entnextcount))) ; ------------------------------------------------------------------------------------ (setq ss (ssget)) (setq num (sslength ss) count 0 howmany 0) (setq cme (getvar "cmdecho")) (setvar "cmdecho" 0) (command "undo" "mark") (setvar "cmdecho" cme) (while (or (<= (setq count (1+ count)) num) (= count nil)) (setq cur (entget (ssname ss (1- count)))) (if (= "INSERT" (cdr (assoc 0 cur))) (setq howmany (+ (matchent (entget blk) cur) howmany)) (setq howmany (+ (matchent sample cur) howmany)) ) ; for attribs in blocks: (if (and blk (= (cdr (assoc 2 cur)) (if blk (cdr (assoc 2 (entget blk)))))) (progn (setq tmpenc entnextcount tsample (entget blk)) (while (>= (setq tmpenc (1- tmpenc)) 0) (setq tsample (entget (entnext (cdar tsample)))) (setq cur (entget (entnext (cdar cur)))) (matchent tsample cur) ) ; while tmpenc )) ; if blocks are equal ) ; while count )) ; if & progn there is no point (setvar "osmode" osm) (if howmany (progn (princ "\nItems modified: ")(princ howmany))) (princ) ) ; Match By (defun matchent (sample cur / count howmany togblk) ; by Brian Forbes - http://www.autolisp.org/ - for use with mb ; this is used by mb (setq count 0 howmany 0 togblk nil) ; togblk T - blocks redefined, togblk nil - blocks stay the same (while (< (setq count (1+ count)) 76) (if mbtext (if (= count 1) (setq count 2))) ; text (if togblk (if (= count 2) (if (and (= "INSERT" (cdr (assoc 0 sample))) (= "INSERT" (cdr (assoc 0 cur)))) nil (setq count 3) ; Block name or attrib tag ) ) (if (= count 2) (setq count 3)) ; Block name or attrib tag ) (if (= count 5) (setq count 6)) ; Hex handle (if (and (not mbpoints) (= count 10)) (setq count 37)) ; All points (if (and (not mbscale) (= count 41)) (setq count 44)) ; X, Y, & Z Scale (if (and (not mbangle) (= count 50)) (setq count 52)) ; Rotation Angle (if (car (assoc count sample)) (if (car (assoc count cur)) (progn (setq cur (subst (assoc count sample) (assoc count cur) cur)) )) ; if cur & progn ) ; if sample ) ; while count (if (entupd (cdr (assoc -1 (entmod cur)))) (setq howmany (1+ howmany))) howmany ) (defun c:mbprop ( / ch) ; By Brian Forbes - http://www.autolisp.org/ ; this is used by mb (princ "\nSelect MB's properties defaults to change, space to quit:")(textscr) (princ "\n1 - Text <") (if mbtext (princ mbtext) (princ 0)) (princ "> Default: 0 = match") (princ "\n2 - Points <") (if mbpoints (princ mbpoints) (princ 0)) (princ "> Default: 0 = no match") (princ "\n3 - Scale <") (if mbscale (princ mbscale) (princ 0)) (princ "> Default: 0 = no match") (princ "\n4 - Angle <") (if mbangle (princ mbangle) (princ 0)) (princ "> Default: 0 = no match") (princ "\n5 - Block def <") (if togblk (princ togblk) (princ 0)) (princ "> Default: 0 = no match") (initget "1 2 3 4 5") (while (setq ch (getkword "\n : ")) (if (= "1" ch) (if mbtext (setq mbtext nil) (setq mbtext 1)) (if (= "2" ch) (if mbpoints (setq mbpoints nil) (setq mbpoints 1)) (if (= "3" ch) (if mbscale (setq mbscale nil) (setq mbscale 1)) (if (= "4" ch) (if mbangle (setq mbangle nil) (setq mbangle 1)) (if (= "5" ch) (if togblk (setq togblk nil) (setq togblk 1)) ))))) ; ifs (initget "1 2 3 4 5") ) ; while (graphscr) (princ) ) ; c:mbprop ; Window lisp by Brian - http://www.autolisp.org/ - happy window (defun c:hw ( / clayr, winsize, winsizeh, ui1, ui2, lt, ent, angl, p1, p2, p3, p4, done p1x, p1y, p2x, p2y, midp1, midp2, winlyr, txtlyr, wintxt, fn) (DEFUN ES () ; Simple Error Handler (DEFUN *ERROR* (erormsg) (setvar "clayer" clayr) (setvar "osmode" osmod) (PRINC))) (DEFUN EU () ; Error Handler w/ Undo (DEFUN *ERROR* (erormsg) (setvar "clayer" clayr) (setvar "osmode" osmod) (COMMAND "_.UNDO" "_END" "U") (PRINC erormsg) (es) (PRINC))) (es) (setvar "cmdecho" 0) (setq clayr (getvar "clayer")) (setq osmod (getvar "osmode")) (setq winlyr "WINDOW") (command "-layer" "make" winlyr "") (setq txtlyr "wintxt") (command "-layer" "make" txtlyr "") (setq count1 0)(setq count2 0) (setq done nil) (while (not done) (progn ; Verify the selection (setq ui1 (getpoint "First point: ")) ; User input 1 (while (not (and (setq ent (ssget ui1)) (or (= "LINE" (setq lt1 (cdr (assoc 0 (entget (ssname ent 0)))))) (= "LWPOLYLINE" lt1) (= "ARC" lt2) (= "CIRCLE" lt2)) )) (setq ui1 (getpoint "First point: "))) (setvar "osmode" 128) (setq ui2 (GETPOINT ui1 "Second Point: ")) ; User input 2 (while (not (and (setq ent (ssget ui2)) (or (= "LINE" (setq lt2 (cdr (assoc 0 (entget (ssname ent 0)))))) (= "LWPOLYLINE" lt2) (= "ARC" lt2) (= "CIRCLE" lt2)) ) ) (setq ui2 (GETPOINT ui1 "Second Point: "))) (setq angl (ANGTOS (ANGLE ui1 ui2) 0 8)) (setq count1 0)(setq count2 0) (while (not done) (progn (setq entlay1 (cdr (assoc 8 (entget (ssname (setq o1ss (ssget "c" ui1 ui1)) count1))))) (setq entlay2 (cdr (assoc 8 (entget (ssname (setq o2ss (ssget "c" ui2 ui2)) count2))))) (setq max1 (sslength o1ss))(setq max2 (sslength o2ss)) (if (and (= max1 1) (= max2 1)) (progn (setq done 1) (princ "\n2 objects found. ") (setq o1 (ssname o1ss count1)) (setq o2 (ssname o2ss count2))) (if (or (= lt1 "LWPOLYLINE") (= lt2 "LWPOLYLINE")) (progn (setq done 1) (princ "\nPolyline found with more than one object on either point, error checking neglected. ") (setq o1 (ssname o1ss count1)) (setq o2 (ssname o2ss count2))) (if (= entlay1 entlay2) (progn (setq o1 (ssname o1ss count1)) (setq o2 (ssname o2ss count2)) ; test for parallel lines (SETQ P1X (CAR (cdr (assoc 10 (entget O1))))) (SETQ P1Y (CADR (cdr (assoc 10 (entget O1))))) (SETQ P2X (CAR (cdr (assoc 11 (entget O1))))) (SETQ P2Y (CADR (cdr (assoc 11 (entget O1))))) (SETQ ang1 (ANGLE (list p1x p1y) (list p2x p2y))) (SETQ P1X (CAR (cdr (assoc 10 (entget O2))))) (SETQ P1Y (CADR (cdr (assoc 10 (entget O2))))) (SETQ P2X (CAR (cdr (assoc 11 (entget O2))))) (SETQ P2Y (CADR (cdr (assoc 11 (entget O2))))) (SETQ ang2 (ANGLE (list p1x p1y) (list p2x p2y))) (if (= ang1 ang2) ;; the following checks to see if the line selected is perpendicular to what we want (if (or (= (atof (angtos ang1 0 0)) (atof (angtos (ANGLE ui1 ui2) 0 0))) (= (atof (angtos ang1 0 0)) (+ (atof (angtos (ANGLE ui1 ui2) 0 0)) 180)) (= (atof (angtos ang1 0 0)) (- (atof (angtos (ANGLE ui1 ui2) 0 0)) 180)) ) (princ) (progn (setq done 1) (setq o1 (ssname o1ss count1)) (setq o2 (ssname o2ss count2))) ) ) ) ))) ; if's (progn (setq count1 (1+ count1)) (setq count2 (1+ count2)) (if (> count1 max1) (setq count1 0)) (if (> count2 max2) (progn (princ "\nTo er is human.") (exit))) ) )) )) (setvar "osmode" 0) (setq winsize (getdist "Window size: ")) (if (not winsize) (setq winsize (if (not curwinsize) (setq curwinsize 30) curwinsize))) (setq wintxt (strcat (rtos (/ winsize 12) 2 0) (rtos (rem winsize 12) 2 0) "48")) (setq winsizeh (/ winsize 2)) (COMMAND "UNDO" "_BE") (eu) ; Error undo changes error checking to undo whatever was done (setvar "lastpoint" ui1) (command "draworder" o1 o2 "" "f") (command "break" o1 ui1 (strcat "@" (rtos winsizeh) "<" (rtos (- (atof angl) 90) 2)) (setq p1 (getvar "lastpoint")) "break" ui1 (strcat "@" (rtos winsizeh) "<" (rtos (+ (atof angl) 90) 2))) (setq p2 (getvar "lastpoint")) (setvar "lastpoint" ui2) (command "break" o2 ui2 (strcat "@" (rtos winsizeh) "<" (rtos (- (atof angl) 90) 2)) (setq p3 (getvar "lastpoint")) "break" ui2 (strcat "@" (rtos winsizeh) "<" (rtos (+ (atof angl) 90) 2))) (setq p4 (getvar "lastpoint")) (setvar "clayer" (cdr (assoc 8 (entget (ssname ent 0))))) (command "line" p1 p3 "" "line" p2 p4 "") (SETQ P1X (CAR p1)) (SETQ P1Y (CADR p1)) (SETQ P2X (CAR p3)) (SETQ P2Y (CADR p3)) (SETQ midp1 (LIST (/ (+ P1X P2X) 2) (/ (+ P1Y P2Y) 2))) (SETQ P1X (CAR p2)) (SETQ P1Y (CADR p2)) (SETQ P2X (CAR p4)) (SETQ P2Y (CADR p4)) (SETQ midp2 (LIST (/ (+ P1X P2X) 2) (/ (+ P1Y P2Y) 2))) (SETQ P1X (CAR p4)) (SETQ P1Y (CADR p4)) (SETQ P2X (CAR p3)) (SETQ P2Y (CADR p3)) (SETQ midp3 (LIST (/ (+ P1X P2X) 2) (/ (+ P1Y P2Y) 2))) (setvar "clayer" winlyr) (command "pline" p1 p3 p4 p2 p1 midp1 midp2 "") (setvar "clayer" txtlyr) (command "mtext" midp3 "j" "bc" "r" (- (atof angl) 90) "@" wintxt "" "move" "l" "" "@" (strcat "@2<" angl) ) (setvar "osmode" osmod) (setvar "clayer" clayr) (command "undo" "_end") (princ) ) ; Window lisp by Brian - custom lisps - http://www.autolisp.org/ ; GAT - Global Attribute Text ; By Brian Forbes - http://www.autolisp.org/ ; Free consulting and custom lisps!! ; ; Permissions: ; Permission is hereby granted to copy and modify this lisp. It is provided "as is" by the author. ; The authorship and url must remain with the copied function. ; Version: ; 1.0 - Oct. 4, 2002 ; 1.1 - Jan. 28, 2003 - Fixed case issue for block names with 2002 ; Explanation: ; This function changes embedded text in selected blocks globally. ; This function must be called from within another function to be useful. It takes in four variables: ; lst, string, entnexts, ss. Without ss (selection set), nothing but the help file comes up. Without ; defining how many entnexts, the help file comes up. Without a list (lst), all blocks are processed. ; Without a string, one is assigned. For more info, run: (gat nil nil nil nil) ; Known bugs: ; none, but I don't know what to do when no entnexts are passed in... help file... ; Examples of calling functions: ; (gat (list "yesnoblock" "yesnoblock2") "Yes" 1 (ssget)) ; (gat (list "block1" "block2") "Sheet 5.3.2" 2 (ssget)) ; ... - Other lisps can be written around this function, just ask. (defun gat (lst string entnexts ss / ce count clay cdrs curlist thesame curloopstr cur_nested ens help) ; Global Atrib Text - by Brian Forbes - http://www.autolisp.org (if ss (progn (setq *ERROR* nil ce (getvar "cmdecho"))(setvar "cmdecho" 0)(command "undo" "be" "undo" "end")(setvar "cmdecho" ce) (if (not string) (setq string " String not passed, and default not set. ")) (setq osm (getvar "osmode") clay (getvar "clayer")) (setvar "osmode" 2) (setq count (sslength ss)) (if (and ; if only text is selected, update the text and skip the rest (= 1 count) (or (= (cdr (assoc 0 (entget (ssname ss (1- count))))) "TEXT") (= (cdr (assoc 0 (entget (ssname ss (1- count))))) "DIMENSION") (= (cdr (assoc 0 (entget (ssname ss (1- count))))) "MTEXT") (= (cdr (assoc 0 (entget (ssname ss (1- count))))) "ATTDEF") ) ) (entupd (cdr (assoc -1 (entmod (subst (cons 1 string) (assoc 1 (entget (ssname ss 0))) (entget (ssname ss 0))))))) (progn ; it wasn't just one item of text (if (not lst) (progn ; if no lst was passed in, work on all objects of type "insert" (while (and (>= count 0) (/= "INSERT" (cdr (assoc 0 (entget (ssname ss (setq count (1- count))))))) ) (ssdel (ssname ss count) ss) ) ; while count > 0 and deleting non-insert objects ) ; progn if gat filter is off (while (>= (setq count (1- count)) 0) (setq cdrs 0 curlst lst thesame T curloopstr (cdr (assoc 2 (entget (ssname ss count))))) (setq curloopstr (strcase (if curloopstr curloopstr "==/\=mmm=/\==")) ) (if (while (and curlst thesame) (if (= curloopstr (car curlst)) (setq thesame nil) ) (setq curlst (cdr curlst)) thesame ) (ssdel (ssname ss count) ss) ) ; if while the list has junk and they are not the same ) ; while count > 0 ) ; If no filter lst (setq count (sslength ss)) (if (> entnexts 0) (progn (while (<= 0 (setq count (1- count))) (setq cur_nested (ssname ss count) ens entnexts) (while (> (setq ens (1- ens)) -1) (setq cur_nested (entnext cur_nested)) ) (setq cur_nested (entget cur_nested)) (entupd (cdr (assoc -1 (entmod (subst (cons 1 string) (assoc 1 cur_nested) cur_nested))))) ) ; while count ) ; progn if entnexts were not nil (progn (setq help T) (princ "\nNo entnexts past in.") (princ "\nAny suggestions about what process could be added for when a user does this?") (princ "\nLet me know: job@autolisp.org\n") ) ) ; if entnexts were not nil ) ; progn wasn't just one item of text ) ; if more than one object (if (> entnexts 0) (princ (strcat " " (itoa (sslength ss))))) ) ; end if (progn (princ "\nNo selection set passed in.")(setq help T)) ; else ) ; if ss (if help (progn (princ "\nUsage: (gat A B C D)\n") (princ "A - Names of blocks to include. If nil is given, all blocks are considered.\n") (princ "B - New text string.\n") (princ "C - Number of entnexts past the object selected. All blocks have nested\n") (princ " objects. Those objects are stored in the dwg table just after the\n") (princ " block inside which they belong. How many objects are in the block and\n") (princ " their draworder affect this variable. Try several numbers and hope for\n") (princ " the text to change. So long as a fairly good error handler is defined,\n") (princ " it shouldn't hurt anything if you are wrong.\n") (princ "D - Selection set. Use (ssget).\n\n") (princ "Passing in a selection set of one object of text renders A and C useless.\n") (princ "Passing in nil for B employs the default string (defined in the function).\n") )) ; if help (princ) ) ; Togtext ; By Brian Forbes - http://www.autolisp.org ; Home of the custom built lisp routine! ; ; Permissions: ; Permission is hereby granted to copy and modify this lisp. It is provided "as is" by the author. ; The authorship and url must remain with the copied function. ; Version: ; 1.0 - Oct. 3, 2002 ; 1.1 - Oct. 7, 2002 - works with nils ; 1.2 - Oct. 9, 2002 - now can accept attrib blocks where the text is the first object, created two ; variables (togtheblocksfortogtext, togtextcase) for more/better functionality ; Explanation: ; This function takes in a list of strings and a selection set. It will extract the text from the ; selection set, search the text strings for matches with those found in the passed list, and replace ; those found strings with the next string in passed list. When the end of the passed list is reached, ; the first string replaces the last. The function searches the entire string of all the strings in ; the selection set for all the strings in the list. A character case issue is documented within ; code of the lisp. ; Known bugs: ;- In r14, for some reason, the passed strings don't like quotation marks. \" doesn't fix it. \\ seems ; to work. It does, however, seem to work in 2002. If anyone figures out a way to get around this ; (or change a " to something else), let me know. ; Examples of calling functions: ;- (togtext (list "HI" "HO") (ssget)) ;- (defun c:tgt ( / ss lst) ; (setq lst (list "NN" "AA" "LLL" "JJ" "HHH") ss (ssget)) ; (togtext lst ss) ; ) ;- (defun c:fixmisspell ( / ss lst) ; (setq lst (list "PURPINDIKYOULER" "PERPENDICULAR") ss (ssget)) ; (togtext lst ss) ; ) ;- (defun c:chgt ( / ss lst st1 st2) ; (princ "Select all objects to consider for replacing text: ") ; (setq ss (ssget) togtextcase T) ; (while (/= st1 "") ; (setq st1 (getstring "Old string :")) ; (if (/= st1 "") (progn ; (setq lst (list st1 (setq st2 (getstring " New string: ")))) ; (togtext lst ss) ; )) ; ) ; (princ) ; ) ; Variables: ; There are two variables that cannot be passed in but must be set globally to control the function. ; They do not need to be initallized. They are nil by default. ; togtheblocksfortogtext - allows (T) or disallows (nil) blocks from being considered ; it only considers the first nested object of the block ; togtextcase - turns string case comparisons on (T) and off (nil) ; These variables may be set within a calling function or within autocad with the (setq ...) command. (defun togtext (lst ss / count count2 ss lst numberinlst oldtxt oldlen string) (setq ce (getvar "cmdecho")) (setvar "cmdecho" 0) (command "undo" "be" "undo" "end") (setvar "cmdecho" ce) (if (not ss) (progn (princ "Select objects: ")(setq ss (ssget)))) (if (or (not lst)(not ss)) (progn (princ "\nTogtext usage:\n(togtext A B)\n\nA - List of strings to toggle between.") (princ "\n Ex: (list \"1\" \"2\")\nB - Selection set or nil.") ) ; progn if lst or ss is nil (progn (setq count (sslength ss) lst (cons " //\\(._.)//\\ //\\(._.)//\\ " lst)) ; You may ask why I added a string to the list. Simple. The numberinlst countdown ; starts at the end, thus the end value is replaced by the first in the list. When ; the countdown finds its way to the beginning again, it thinks to replace the first ; string in the list too. It doesn't know that that string was already replaced. ; The added string is to ensure that no string is replaced twice. (while (>= (setq count (1- count)) 0) (if (and (/= (cdr (assoc 0 (entget (ssname ss count)))) "TEXT") (/= (cdr (assoc 0 (entget (ssname ss count)))) "DIMENSION") (/= (cdr (assoc 0 (entget (ssname ss count)))) "MTEXT") (/= (cdr (assoc 0 (entget (ssname ss count)))) "ATTDEF") (if togtheblocksfortogtext (/= (cdr (assoc 0 (entget (ssname ss count)))) "INSERT") T ) ) (ssdel (ssname ss count) ss) )) ; if & while (setq count (sslength ss)) (while (>= (setq count (1- count)) 0) (setq curent (entget (ssname ss count))) (if (= (cdr (assoc 0 curent)) "INSERT") (progn (setq curent (entnext (cdr (assoc -1 curent)))) (setq curent (if curent (entget curent) nil)) (if (not (assoc 1 curent)) (setq curent nil)) )) ; if curent is a block, select the nested or make it nil (setq oldtxt (cdr (assoc 1 curent)) oldlen (if oldtxt (strlen oldtxt)) string nil numberinlst (length lst) ) (while (and (> (setq numberinlst (1- numberinlst)) -1) curent) (setq nextlst (nth (if (= numberinlst (1- (length lst))) 0 (1+ numberinlst)) lst) curlen (strlen (nth numberinlst lst)) count2 -1 ) (while (<= (setq count2 (1+ count2)) oldlen) (if (if togtextcase (= (substr oldtxt (1+ count2) curlen) (nth numberinlst lst)) ; List is case sensitive (= (strcase (substr oldtxt (1+ count2) curlen)) (nth numberinlst lst)) ; List is CAPS ) ; The string being compared is made to be upper case. If you wish to make ; the function case sensitive, (setq togtextcase T) (progn (setq oldtxt (setq string (strcat (substr oldtxt 1 count2) nextlst (substr oldtxt (+ (1+ count2) curlen) (- (- oldlen count2) curlen)) ) )) (setq count2 (+ count2 (strlen nextlst)) oldlen (strlen oldtxt) ) ) ; progn ) ; if strings equal ) ; while there's something left to compare in the string ) ; while there's another string in lst (if string (entupd (cdr (assoc -1 (entmod (subst (cons 1 string) (assoc 1 curent) curent)))))) ) ; While there's an object left in the selection set )) (princ) ) ;-- ADDED 5/7/08 -- ; open an xref by clicking it (defun c:oo () (oo nil) );start in same autocad (defun c:ooo () (oo T ) );start in new autocad (defun oo (stapp / selobj filen tblname path pos xreffile) ; by Brian Forbes - http://www.autolisp.org (setvar "cmdecho" 0) (setq selobj (entget (car (entsel "\nSelect Xref that you wish to enter: ")))) (setq filen (cdr (assoc 2 selobj))) (setq tblname (tblobjname "block" filen)) (if tblname (setq path (cdr (assoc 1 (entget tblname))))) (if (/= path "") (if (not (findfile path)) (progn (setq pos 0) (setq xreffile path) (while (setq pos (vl-string-search "\\" xreffile)) (setq xreffile (substr xreffile (+ 2 pos) (- (strlen xreffile) pos))) ) )) ; if path not found & progn ) ; if path (if xreffile (if (findfile xreffile) (setq path (findfile xreffile)))) (if (and (/= (substr path 2 1) ":") (/= path "")) (setq path (strcat (getvar "dwgprefix") path))) (princ path) (COMMAND "_QSAVE") (if (/= path "") (if (= 0 (getvar "sdi")) (cmdopen path) (if stapp (startapp "acad.exe" (findfile path)) (command "open" path) ) ; if stapp ) ; if (if stapp (startapp "acad.exe" (strcat filen ".dwg")) (if (= 0 (getvar "sdi")) (cmdopen (findfile path)) (command "open" (findfile path))) ) ; if ) ; if path (PRINC) ) ; oo - new and improved! - 9-10-03, 7-20-06, 8-21-06 (defun cmdOpen (name) ; by others (vl-load-com) (if (= 0 (getvar "SDI")) (vla-activate (vla-open (vla-get-documents (vlax-get-acad-object))name)) (vla-sendcommand (vla-get-activedocument (vlax-get-acad-object)) (strcat "(command \"_.OPEN\")\n" name "\n") ) ; vla-activate ) ; if sdi ) ; defun cmdopen (defun c:nl (/ sample samlst layr a blk trail) ; get nested layer names for selected objects - Brian Forbes - http://www.autolisp.org/ ; globals: nl_basepoint nl_finallist (if nl_basepoint (setq sample (nentselp nl_basepoint) nl_basepoint nil) (setq sample (nentselp "Select base object for layer names: ")) ) ; if (if sample (progn (setq samlst (entget (car sample))) (setq layr (cdr (assoc 8 samlst))) (setq nl_finallist (list layr)) (princ "\nBase Layer: ") (princ layr) (setq trail (simpletrail sample)) (setq trail (vl-remove (last trail) trail)) (foreach a trail (princ " --> ") (setq nl_finallist (append nl_finallist (list (princ (cdr (assoc 8 (entget (car a)))))))) ) ; foreach (if (> (length sample) 2) (foreach a (last sample) (princ " --> ") (setq samlst (entget a)) (setq nl_finallist (append nl_finallist (list (princ (cdr (assoc 8 samlst)))))) ) ; foreach ) ; if )) ; if & progn (princ) ) ; nl (defun simpletrail (ent / ent entdata enttype endlist ) ; extract by brian (setq Ent (car Ent)) (setq EntData (entget Ent)) (setq EntType (cdr (assoc 0 EntData))) (while (and EntData (/= EntType "BLOCK_RECORD")) (setq EndList (cons (list Ent EntType) EndList)) (setq Ent (cdr (assoc 330 EntData))) (setq EntData (entget Ent)) (setq EntType (cdr (assoc 0 EntData))) ) endlist ) ; simpletrail (defun c:ln ( / cme ) ; get lines of a certain length - Brian Forbes - http://www.autolisp.org/ (setq obj (entget (car (entsel "Select sample object for line length and layer: ")))) (setq ss (ssget "X" (list (cons 0 "LINE") (assoc 8 obj)))) (setq dstexact (distance (cdr (assoc 10 obj)) (cdr (assoc 11 obj))) accuracy 2.0) (setq dst (+ dstexact accuracy) dst2 (- dstexact accuracy)) (setq count (sslength ss) cme (getvar "cmdecho")) (command "move") (while (>= (setq count (1- count)) 0) (setq curent (entget (ssname ss count))) (if (or (and (<= (distance (cdr (assoc 10 curent)) (cdr (assoc 11 curent))) dst) (>= (distance (cdr (assoc 10 curent)) (cdr (assoc 11 curent))) dst2) ) (= (distance (cdr (assoc 10 curent)) (cdr (assoc 11 curent))) dstexact) ) (command (ssname ss count))) ); while (command "") (princ) ) ; defun ln (defun c:byall ( / a aa i lst sslst flst) ; set all blocks bylayer - Brian Forbes - http://www.autolisp.org/ (setq lst (findblocknames)) (foreach a lst (setq aa (cdr (assoc 330 a))) (if (not (assoc 1 (entget aa))) (setq flst (append flst (list aa)))) ) ; foreach (foreach a flst (bycolor a) ) ; foreach (setq sslst (ssget "x" (list (cons 2 "*")))) (if sslst (setq a (sslength sslst)) (setq a -1)) (while (>= (setq a (1- a)) 0) (setq i (ssname sslst a)) (if (member (cdr (assoc 2 (entget i))) lst) (entupd i)) ; if the block is not an xref, refresh it ) ; while (princ) ) ; byall (defun findblocknames ( / tblitem xreflist) ; Use with byall - Brian Forbes - http://www.autolisp.org/ (setq tblitem (tblnext "block" T)) (while tblitem (if (and (not (wcmatch (cdr (assoc 2 tblitem)) "*|*")) (not (assoc 1 tblitem))) (setq xreflist (append xreflist (list (entget (tblobjname "block" (cdr (assoc 2 tblitem))))) ) ) ) ; if (setq tblitem (tblnext "block")) ) xreflist ) ; findblocknames (defun bycolor (input / xrf xrfn cme laylst a flaylst nflaylst ssfilter allblockitems) ; by Brian Forbes - http://www.autolisp.org - use with byall (setq b (entget input)) (setq bn (cdr (assoc 2 b))) (setq itemlst (findblkobj bn "*" (list (cons 62 "*")))) (foreach a itemlst (stripcolor a) ) ; foreach (entupd input) ) ; bycolor (defun stripcolor (nentselpval / en bn el success) ; strip an object of its color - by Brian Forbes - http://www.autolisp.org/ (if (= (type nentselpval) 'LIST) (progn (setq en (car nentselpval)) (setq bn (car (last nentselpval))) )(progn (setq en nentselpval) (setq bn (cdr (assoc 330 (entget en)))) )) (setq el (entget en)) (setq success (entmod (subst (cons 62 256) (assoc 62 el) el))) (entupd bn) success ) ; stripcolor (defun findblkobj (blkname searchitem filterlst / tblobj pointer lst a b passed) ; find objects in a block ; by Brian Forbes - http://www.autolisp.org/ ; samples: ; (findblkobj "dbb" "LINE" (list (cons 8 "ENG-*"))) ; (findblkobj "jt" "ATTDEF" nil) (if blkname (progn (setq tblobj (tblobjname "block" blkname)) (setq pointer tblobj) (if (not searchitem) (setq searchitem "*")) ; wcmatch added on this and next line for use with bycolor (while (setq pointer (entnext pointer)) (if (wcmatch (cdr (assoc 0 (entget pointer))) searchitem) (progn (setq lst (append lst (list pointer))) )) ; if & progn ) ; while (if filterlst (foreach a lst (progn (setq passed T) (foreach b filterlst (if (not (member b (entget a))) (if (not (wcmatch (if (= (type (cdr (assoc (car b) (entget a)))) 'STR) (cdr (assoc (car b) (entget a))) "") (if (= (type (cdr b)) 'STR) (cdr b) "Hate what is evIL") ) ; wcmatch ) ; not (setq passed nil) ) ; if ) ; if member b ) ; foreach b (if (not passed) (setq lst (vl-remove a lst))) )) ; foreach & progn ) ; if filterlst )) ; if & progn lst ) ; findblkobj ; bind all the xrefs to the drawing, removing excess layers not used (defun c:ptbindall ( / xrefs a ss items) ; By Brian Forbes - http://www.autolisp.org/ (c) 2008 (setq xrefs (getxreflst)) (foreach a xrefs (setq ss (ssget "x" (list (cons 2 a)))) (if ss (setq items (append items (list (ssname ss 0))))) ) ; foreach (foreach a items (ptbind a) ) ; foreach ; purge here (princ " *** Batch complete! ***") (princ) ) ; pt bind all (defun getxreflst (/ roughxrlst a cur xrlst) ; use with ptbindall - Brian Forbes - http://www.autolisp.org/ (setq roughxrlst (findxref)) (foreach a roughxrlst (setq cur (cdr (assoc 2 a))) (setq xrlst (append xrlst (list cur))) ) ; foreach xrlst ) ; getxreflst (defun findxref ( / tblitem xreflist) ; by Brian Forbes - http://www.autolisp.org/ (setq tblitem (tblnext "block" T)) (while tblitem (if (assoc 1 tblitem) (setq xreflist (append xreflist (list (entget (tblobjname "block" (cdr (assoc 2 tblitem))))) ) ) ) (setq tblitem (tblnext "block")) ) xreflist ) (defun ptbind (input / xrf xrfn cme laylst a flaylst nflaylst ssfilter allblockitems); Brian Forbes - http://www.autolisp.org/ ; use with ptbindall (setq xrf (entget input)) (setq xrfn (cdr (assoc 2 xrf))) (setq cme (getvar "cmdecho"))(setvar "cmdecho" 0) (princ "Finding layers... ") (setq laylst (getfilteredlaylist (strcat xrfn "|*"))) ; all frozen layers are NOT filtered out (foreach a laylst ; find if layer exists in dwg and rename if it does (if (= (logand (cdr (assoc 70 (tblsearch "layer" a))) 1) 1) ; got this online - sees if layer is frozen (setq flaylst (append flaylst (list a))) ) ; if ) ; foreach (foreach a flaylst (setq a (substr a (+ (vl-string-position 124 a) 2) (strlen a))) (setq nflaylst (append nflaylst (list (strcat xrfn "$0$" a)))) ) ; foreach (princ "Binding... ") (command "xref" "bind" xrfn) (princ "Thawing layers... ") (command "insert" xrfn "0,0,0" "" "" "" "explode" "l") (setq ssfilter (list (cons -4 "")))) (command "") (command "zoom" "e") (setq allblockitems (ssget "p")) (command "erase" (ssget "x" ssfilter) "") (princ "Recreating block... ") (command "block" xrfn "yes" "0,0" allblockitems "") (setvar "cmdecho" cme) (princ " Done.") (princ) ) ; ptbind (defun getfilteredlaylist (filter / laylist nll name) ; http://www.autolisp.org/ (tblnext "layer" T) (while (setq nll (tblnext "layer")) (setq name (cdr (assoc 2 nll))) (if (wcmatch name filter) (setq laylist (append laylist (list name))) ) ; if ) ; while laylist ); getlaylist ; Shorten layer names (defun c:trunclayers ( / num done) ; By Brian Forbes - http://www.autolisp.org/ (trunclayers (while (and (not done) (setq num (getint "Pick a number (5-20): "))) (if (or (< num 5) (> num 21)) (setq num nil) (setq done T)) num)) ) ; c:trunclayers (defun trunclayers (chars / str chars lyrs countchanged substlst a a1) ; make layernames x characters long ; by Brian Forbes - http://www.autolisp.org/ (setq str "") (repeat chars (setq str (strcat str "?"))) (setq str (strcat str "*")) (setq lyrs (getfilteredlaylist str)) (foreach a lyrs (if (wcmatch a "*|*") (setq lyrs (vl-remove a lyrs)))) (setq countchanged (length lyrs)) ; replacing key words (setq substlst (list ; samples of keywords - in this case, architectural (list "_" " ") (list "_" "__") (list "$" "&") (list "$" "+") (list "$" "`#") (list "$" "%") (list "AV" "ABOVE")(list "AP" "APPLIANCE")(list "B" "BASIN")(list "B" "BATH")(list "BW" "BELOW")(list "B" "BEYOND")(list "B" "BLOCK")(list "C" "CIRCUIT") (list "C" "CLINICAL")(list "C" "COLUMN")(list "C" "COUNTER")(list "D" "DESCRIPTION")(list "D" "DRAIN")(list "DBL" "DOUBLE") (list "EQ" "EQUIPMENT")(list "R" "EDGE")(list "E" "ELEMENTS")(list "F" "FAUC")(list "F" "FIXTURE")(list "FL" "FLUSH") (list "H" "HOSE")(list "K" "KITCHEN")(list "K" "KITCH")(list "L" "LARGE")(list "LN" "LINE") (list "M" "MEDIUM")(list "M" "MED")(list "M" "MILLWORK")(list "N" "NAME")(list "W" "NEW") (list "N" "NOTE")(list "OH" "OVERHEAD")(list "O" "OPERATION")(list "O" "OUTLET")(list "P" "PATTERN")(list "P" "PLAN")(list "P" "PLUMB") (list "P" "POCHE")(list "Q" "QUIET")(list "R" "ROOF")(list "RM" "ROOM")(list "SV" "SERVICE") (list "S" "SINGLE")(list "S" "SINK")(list "S" "SIDING")(list "S" "SMALL")(list "S" "STAIR")(list "ST" "STANDARD") (list "S" "SWITCH")(list "T" "TANK")(list "T" "TITLE")(list "T" "TOILET")(list "U" "UTILITY") (list "V" "VANITY")(list "W" "WALL")(list "W" "WINDOW") )) ; substlst (foreach a lyrs (setq a1 (strcase a)) (foreach a substlst (while (wcmatch a1 (strcat "*" (cadr a) "*")) (setq a1 (vl-string-subst (car a) (if (= "`" (substr (cadr a) 1 1)) (substr (cadr a) 2 (strlen (cadr a))) (cadr a)) ; this may not be necessary. The error that was happening was caused by setting "extnames" to 0 ; I no longer do that, so I probably don't need to test for those characters. Oh well! a1) ; vl-string-subst ) ; setq ) ; while ; (while (wcmatch a1 (princ (strcat "*" (cadr a) "*"))) (setq a1 (vl-string-subst (car a) (cadr a) a1))) ) ; foreach (if (< (strlen a1) chars) (progn (command "rename" "la" a a1) (setq lyrs (vl-remove a lyrs))) ; otherwise, loop with counter, then change the name - tell user (progn (princ "Too long after keyword search, truncating: ")(princ a1) (setq count 0) (while (tblobjname "layer" (setq a1-out (strcat (substr a1 1 (- chars 2)) (itoa count)))) (setq count (1+ count))) (command "rename" "la" a a1-out)(setq lyrs (vl-remove a lyrs)) )) ; if & progn ) ; foreach (princ (strcat "\n" (itoa countchanged) " layers changed.")) (princ) ) ; trunclayers ; Isolate layers on an xref and make them visible on a new instance of the same xref ; by Brian Forbes - http://www.autolisp.org/ ; Known issue: ; With xrefs that are long or have spaces in them, the command line rename does not work, so my lisp doesn't. ; As long as you can keep your xref file names without spaces, this should work. (defun c:xi ( / laylst oxr a nn opt oblk path name-pos tlaylst egc layerstate name name_before oxr cl cur rename inc inc2) ; xref isolate, select layers for new insert of same xref to have exclusively on it (setq nl_basepoint (entsel "Select xref layers to be divided onto a separation: ")) (setq oblk (car nl_basepoint) opt (cadr nl_basepoint) nl_basepoint (cadr nl_basepoint)) (setq nl_finallist nil) (while (setq a (progn (princ "\n")(c:nl) nl_finallist)) (foreach a a (if (and (not (member a laylst)) (wcmatch a (strcat (if oxr oxr "*") "|*")) (wcmatch a (if oxr (strcat "*" oxr "*") "*"))) (progn (if (not oxr) (setq oxr (substr a 1 (vl-string-position (ascii "|") a)))) (setq laylst (append laylst (list a))) (if (not nn) (setq nn (substr a (+ (strlen oxr) 2)))) (princ " Accepted.") )(princ " Rejected.")) ; if & progn ) ; foreach (setq nl_finallist nil) ) ; while (setq path (cdr (assoc 1 (entget (tblobjname "block" oxr))))) (setq name-pos (vl-string-position (ascii "\\") path nil T)) (if name-pos (setq name (substr path (+ 2 name-pos) (- (strlen path) name-pos 5))) (setq name path)) (setq tlaylst (getfilteredlaylist (strcat oxr "|*"))) (foreach a tlaylst (setq egc (entget (tblobjname "layer" a))) (setq layerstate (append layerstate (list (list (substr a (+ 2 (vl-string-position (ascii "|") a)) (strlen a)) ; name of layer (assoc 62 egc)(assoc 6 egc)(assoc 290 egc) ; 62-color, 6-linetype, 290-plotting (don't add, rearrange) )))) ; setq ) ; foreach (command "undo" "be") (setq inc 49) ; 49="1" ; set name to remove bad block characters and make name unique (setq name_before name) (setq name (vl-string-translate "` <>/\\\":?,*|='" "~_~~~~~~~~~~~~" name)) ; I remember a system variable that allows backward compatibility for spaces in xref names - can't remember the var ; and my help file isn't working in Vista (if (/= name_before name) (alert "The xref contains illegal characters. \nRename could not be done from the command line. \nIn xref or rename dialog, please remove spaces and:\n`<>/\\\":?,*|='")) ; by Brian Forbes - http://www.autolisp.org/ (while (tblobjname "block" (strcat oxr "-" (chr inc))) (setq inc (1+ inc))) ; why use oxr instead of name? 3-12 (if (= (strcase name) (strcase oxr)) (progn (setq rename T) (command "rename" "b" oxr (strcat name "-" (chr inc)))) ) ; if ; rename original xref IF it doesn't already have a different name - keep new name as original one (if (and rename (not (tblobjname "block" (strcat oxr "-" (chr inc))))) (progn (setq opt nil) (alert "Could not rename original xref."))(progn (setq inc2 49) ; 49="1" (while (tblobjname "block" (strcat nn "-" (chr inc2))) (setq inc2 (1+ inc2))) (setq nn (strcat nn "-" (chr inc2))) (command "xref" "o" path "0,0" "" "" "" "rename" "b" name nn "layer" "f" (strcat nn "|*")) (if (= (cdr (assoc 2 (entget (entlast)))) nn) (entdel (entlast)) (alert "Something has gone wrong. New xref was not renamed or not inserted.")) (foreach a laylst (command "th" (strcat nn "|" (substr a (+ 2 (strlen oxr)) (strlen a)))) ; remove orig. xref name, add new ) ; foreach (command "") (foreach a layerstate (setq cur (entget (tblobjname "layer" (strcat nn "|" (car a))))) (setq cl (cdr (caddr a))) (if (wcmatch cl "*|*") (setq cl (vl-string-subst nn oxr cl))) (setq cur (subst (cadr a) (assoc 62 cur) cur)) (setq cur (subst (cons 6 cl) (assoc 6 cur) cur)) (setq cur (subst (cadddr a) (assoc 290 cur) cur)) (entmod cur) ) ; foreach layersate (command "copy" oblk "" "0,0" "0,0") (setq el (entlast)) (entmod (subst (cons 2 nn) (assoc 2 (entget el)) (entget el))) )) ; if & progn "couldn't rename" (command "undo" "e") (if opt (command "move" "l" "" opt)) (princ) ) ; c:xi