├── drawing scale.pdf ├── Copy2LayoutsV1-1.lsp ├── DeleteBlocksV1-1.lsp ├── StripMtext v5-0c.lsp ├── cursorrotatev1-0.lsp ├── drawing scale.docx ├── OutlineObjectsV1-1.lsp ├── copy2drawingsv1-3.lsp ├── FreezeAllLayers.lsp ├── selectDel.lsp ├── LAV.lsp ├── portme.lsp ├── UnthawSpecificLayers.lsp ├── zoomExtenseAllLayouts.lsp ├── RELOADXREF.LSP ├── continuosarc.lsp ├── continuousLine.lsp ├── uline.lsp ├── deleteLayouts.lsp ├── arp.lsp ├── LayFreezeViewportLayers.lsp ├── pageset.lsp ├── rotateMultipleBlocks.lsp ├── ssw.lsp ├── LayerAll.lsp ├── VCD.lsp ├── dwgClean.lsp ├── drawlines.lsp ├── PAO.LSP ├── vpfreeze.lsp ├── textStyle.lsp ├── clearwipeouts.lsp ├── MLeaderTextColor.lsp ├── changestyle.lsp ├── dwgCAD.lsp ├── rcpClean.lsp ├── NOZ.LSP ├── ALLOWEXPLODEBLOCKS.lsp ├── MultipleXr.lsp ├── ReplaceTXTwBlock.lsp ├── blkto0.lsp ├── breakAtIntersection.lsp ├── dwgFOO.lsp ├── README.md ├── ScaleAboutCenters.lsp ├── RB.lsp ├── mhatch.lsp ├── changeLayoutNames.lsp ├── fixLeader.lsp ├── circlewidth.lsp ├── xxx.lsp ├── deleteAroundArea.lsp └── replaceBlock.lsp /drawing scale.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Fandoozle/AutoCAD/HEAD/drawing scale.pdf -------------------------------------------------------------------------------- /Copy2LayoutsV1-1.lsp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Fandoozle/AutoCAD/HEAD/Copy2LayoutsV1-1.lsp -------------------------------------------------------------------------------- /DeleteBlocksV1-1.lsp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Fandoozle/AutoCAD/HEAD/DeleteBlocksV1-1.lsp -------------------------------------------------------------------------------- /StripMtext v5-0c.lsp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Fandoozle/AutoCAD/HEAD/StripMtext v5-0c.lsp -------------------------------------------------------------------------------- /cursorrotatev1-0.lsp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Fandoozle/AutoCAD/HEAD/cursorrotatev1-0.lsp -------------------------------------------------------------------------------- /drawing scale.docx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Fandoozle/AutoCAD/HEAD/drawing scale.docx -------------------------------------------------------------------------------- /OutlineObjectsV1-1.lsp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Fandoozle/AutoCAD/HEAD/OutlineObjectsV1-1.lsp -------------------------------------------------------------------------------- /copy2drawingsv1-3.lsp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Fandoozle/AutoCAD/HEAD/copy2drawingsv1-3.lsp -------------------------------------------------------------------------------- /FreezeAllLayers.lsp: -------------------------------------------------------------------------------- 1 | (defun c:freezeall () 2 | (setvar 'cmdecho 0) ; Disable command echoing 3 | (command "_.VPLAYER" "Freeze" "*" "CURRENT" "") ; Freeze all layers in the current viewport 4 | (setvar 'cmdecho 1) ; Re-enable command echoing 5 | (princ) ; Print a newline character 6 | ) 7 | -------------------------------------------------------------------------------- /selectDel.lsp: -------------------------------------------------------------------------------- 1 | ;; SelectDelete 2 | ;; pre select an element on a drawing 3 | ;; run the command to select similar elements (ie selectsimilar) and deletes the selections 4 | ;; helps with tedious tasks 5 | (DEFUN C:SD () 6 | (command "selectsimilar") ;; select similar elements 7 | (command "erase") ;; erase 8 | ) ;;END DEFUN -------------------------------------------------------------------------------- /LAV.lsp: -------------------------------------------------------------------------------- 1 | (defun C:LAV (/ ss n vp); = Lock All Viewports 2 | (repeat (setq n (sslength (setq ss (ssget "_X" '((0 . "VIEWPORT")))))) 3 | (if (> (cdr (assoc 69 (entget (setq vp (ssname ss (setq n (1- n))))))) 1); not the Paper Space Viewport of its Layout 4 | (vla-put-DisplayLocked (vlax-ename->vla-object vp) -1); lock it 5 | 6 | ); if 7 | ); repeat 8 | ); defun 9 | 10 | (C:LAV) -------------------------------------------------------------------------------- /portme.lsp: -------------------------------------------------------------------------------- 1 | ;; this exports the current drawing to a later version (2013) then closes the drawing without saving 2 | (defun c:PORTME ( / ) 3 | (command "ZOOM" "E");; zoom to extents 4 | (vlax-for OpenDwgs (vla-get-documents (vlax-get-acad-object)) 5 | (command "-exporttoautocad" "F" "2013" "" "")(command)(command) 6 | ) vlax-for 7 | (command "_CLOSE" "_Y") ;; closes the drawing without saving 8 | (princ) 9 | );; end PORTME 10 | -------------------------------------------------------------------------------- /UnthawSpecificLayers.lsp: -------------------------------------------------------------------------------- 1 | (defun c:unthawall () 2 | (setvar 'cmdecho 0) 3 | (command "_.VPLAYER" "THAW" "A-Building-Exst" "CURRENT" "") 4 | (command "_.VPLAYER" "THAW" "A-Building-Hatch" "CURRENT" "") 5 | (command "_.VPLAYER" "THAW" "A-Cable Tray Exst" "CURRENT" "") 6 | (command "_.VPLAYER" "THAW" "A-Equip-Exst" "CURRENT" "") 7 | (command "_.VPLAYER" "THAW" "G-Ground BAR-Exst" "CURRENT" "") 8 | (setvar 'cmdecho 1) 9 | (princ) 10 | ) 11 | 12 | -------------------------------------------------------------------------------- /zoomExtenseAllLayouts.lsp: -------------------------------------------------------------------------------- 1 | ;; ZoomExtentsAllLayouts.lsp [command name: ZEAL] 2 | ;; To get into all Layouts, go to Paper Space in and Zoom to the Extents for each, 3 | ;; ending in Model Space and Zooming to the Extents there also. 4 | ;; Kent Cooper, November 2011 5 | (defun C:ZEAL () 6 | (foreach lay (layoutlist) 7 | (setvar 'ctab lay) 8 | (command "_.pspace" "_.zoom" "_extents") 9 | ); end foreach 10 | (setvar 'ctab "Model") 11 | (command "_.zoom" "_extents") 12 | ); end defun -------------------------------------------------------------------------------- /RELOADXREF.LSP: -------------------------------------------------------------------------------- 1 | ;; This AutoLISP routine reloads all external references (xrefs) in the current drawing while turning off the VISRETAIN system variable to avoid any unexpected changes. 2 | ;; To use it, type XRE on the command line. 3 | 4 | (defun c:XRE ( / ) 5 | (setvar 'VISRETAIN 0) ;; Set VISRETAIN to 0 to avoid any unexpected changes 6 | (command "-XREF" "r" "*") ;; Reload all external references 7 | (setvar 'VISRETAIN 1) ;; Set VISRETAIN back to 1 8 | (command "QSAVE") ;; Quick save the drawing 9 | ) ;; end of defun block 10 | -------------------------------------------------------------------------------- /continuosarc.lsp: -------------------------------------------------------------------------------- 1 | (defun C:WA (/ pt1 pt2); = Wiring Arcs 2 | (setvar 'osmode 64); Insertion 3 | (setq pt1 (getpoint "\nStart point for Arc(s): ")) 4 | (while (setq pt2 (getpoint "\nEnd of Arc: ")) 5 | (command 6 | "_.arc" pt1 "_e" pt2 "_direction" ; [spelling out "_end" is taken as Osnap call] 7 | (angtos (apply (if (> (car pt2) (car pt1)) '+ '-) (list (angle pt1 pt2) (/ pi 5)))) 8 | ; change 5 above to lower number for more bulge, higher for less 9 | ); command 10 | (setq pt1 pt2); for start of next Arc 11 | ); while 12 | ); defun -------------------------------------------------------------------------------- /continuousLine.lsp: -------------------------------------------------------------------------------- 1 | (defun C:WL (/ pt1 pt2); = Wiring Line 2 | (setvar 'osmode 64); Center 3 | (setq pt1 (getpoint "\nStart point for Line(s): ")) 4 | (while (setq pt2 (getpoint "\nEnd of Line: ")) 5 | (command 6 | "_.line" pt1 "_e" pt2 "_direction" ; [spelling out "_end" is taken as Osnap call] 7 | (angtos (apply (if (> (car pt2) (car pt1)) '+ '-) (list (angle pt1 pt2) (/ pi 5)))) 8 | ; change 5 above to lower number for more bulge, higher for less 9 | ); command 10 | (setq pt1 pt2); for start of next Line 11 | ); while 12 | ); defun -------------------------------------------------------------------------------- /uline.lsp: -------------------------------------------------------------------------------- 1 | (defun c:uline (/ sset num ent sub) 2 | (setq sset (ssget '((0 . "*text")))) 3 | (setq num 0) 4 | (repeat (sslength sset) 5 | (setq 6 | ent (entget (ssname sset num)) 7 | sub (cdr (assoc 1 ent)) 8 | ) 9 | (if (= (cdr (assoc 0 (entget (ssname sset num)))) "TEXT") 10 | (setq ; TEXT 11 | sub (vl-string-subst "" "%%U" sub) 12 | sub (vl-string-subst "" "%%u" sub) 13 | ) 14 | (setq ; MTEXT 15 | sub (vl-string-subst "" "{\\L" sub) 16 | sub (vl-string-subst "" "}" sub) 17 | ) 18 | ) 19 | (setq 20 | sub (subst (cons 1 sub)(assoc 1 ent) ent) 21 | num (1+ num) 22 | ) 23 | (entmod sub) 24 | ); end repeat 25 | (princ) 26 | ) -------------------------------------------------------------------------------- /deleteLayouts.lsp: -------------------------------------------------------------------------------- 1 | ; This function deletes all layouts except the Model and Layout1 tabs 2 | (DEFUN C:DelLayouts (/ layouts) ; Define a function with the name DelLayouts and a local variable layouts 3 | (vl-load-com) ; Load the Visual LISP COM support 4 | (setq layouts ; Assign the layouts variable 5 | (vla-get-layouts ; Get the layouts collection object 6 | (vla-get-activedocument (vlax-get-acad-object)) ; Get the active document object 7 | ) 8 | ) 9 | (mapcar '(lambda (layout) ; Apply a function to each element of a list 10 | (vla-delete (vla-item layouts layout)) ; Delete the layout object by name 11 | ) 12 | (layoutlist) ; Get the list of layout names 13 | ) 14 | (princ) ; Exit the function quietly 15 | ) 16 | -------------------------------------------------------------------------------- /arp.lsp: -------------------------------------------------------------------------------- 1 | ;; This routine creates an array along a path for a JFK barrier wall 2 | ;; It prompts the user to select objects to array, select the path along which to array, 3 | ;; and enter a distance between objects (defaulting to 6 feet if not entered). 4 | ;; It then calls the "._arraypath" command with the selected objects, path, and distance as arguments. 5 | (defun c:ARP (/ sel path dist) ;Arraypath for JFK barrier wall 6 | 7 | (if (and (setq sel (ssget)) 8 | (setq path (car (entsel "\nSelect path:"))) 9 | (setq dist (cond ((getdist "\nEnter the Distance Between Objects <6 ft>: ")) 10 | (6.))) 11 | (initcommandversion) 12 | ) 13 | (command "._arraypath" sel "" path "I" dist "F" "M" "D" "X" )) 14 | (princ) 15 | ) 16 | -------------------------------------------------------------------------------- /LayFreezeViewportLayers.lsp: -------------------------------------------------------------------------------- 1 | (defun c:layfrz (/ LM:lst->str lst layers) 2 | ;; List to String - Lee Mac 3 | (defun LM:lst->str (lst del / str) 4 | (setq str (car lst)) 5 | (foreach itm (cdr lst) (setq str (strcat str del itm))) 6 | str 7 | ) 8 | 9 | ;; Get a list of all layers in the active document 10 | (vlax-for obj (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) 11 | (setq lst (cons (vla-get-name obj) lst)) 12 | ) 13 | 14 | ;; Convert the list of layer names to a comma-separated string 15 | (setq layers (LM:lst->str lst ",")) 16 | 17 | ;; Freeze the layers using the VPLAYER command 18 | (command "_.vplayer" "_freeze" layers "_current" "") 19 | 20 | (princ) ; Print a newline character 21 | ) 22 | -------------------------------------------------------------------------------- /pageset.lsp: -------------------------------------------------------------------------------- 1 | ; Jason Piercey . May 16th, 2003 2 | ; assign a pagesetup to a layout 3 | ; [document] - vla-object, layout object 4 | ; [layout] - string, layout name 5 | ; [setup] - string, pagesetup to assign 6 | ; return: T or nil 7 | ; example: (putPagesetup [document] [layout] [setup]) 8 | ; revised: July 27th, 2003 9 | ; trimmed off the fat and used (vl-catch-all.....) 10 | (defun putPagesetup (document layout setup) 11 | (if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda () (vla-copyfrom (vla-item (vla-get-layouts document) layout) (vla-item (vla-get-plotconfigurations document) setup) ) ) ) ) ) 12 | nil t 13 | ) 14 | ) 15 | 16 | ;To assign a pagesetup named "test" to all layouts defined in the current document. 17 | (setq *doc* (vla-get-activedocument (vlax-get-acad-object))) 18 | (foreach x (layoutlist) (putPagesetup *doc* x "test")) -------------------------------------------------------------------------------- /rotateMultipleBlocks.lsp: -------------------------------------------------------------------------------- 1 | ;| RMB 2 | ========================================================================= 3 | Rotate Block(s) at its insertion point(s) by specifying rotation angle 4 | =========================================================================|; 5 | (vl-load-com) 6 | (defun C:RMB (/ CN ENT OS RA SS) 7 | (setq SS (ssget (list (cons 0 "INSERT")))) 8 | (if *RA (setq RA (getdist (strcat "Specify rotation angle <" (angtos *RA) ">: "))) 9 | (progn 10 | (initget 1) 11 | (setq RA (getdist "\nSpecify rotation angle: ")) 12 | ); progn 13 | ); if 14 | (if (not RA) 15 | (setq RA *RA) 16 | ); if 17 | (setq *RA RA) 18 | (repeat (setq CN (sslength SS)) 19 | (setq CN (1- CN) 20 | ENT (ssname SS CN) 21 | OS (vlax-ename->vla-object ENT) 22 | ); setq 23 | (vla-put-rotation OS (+ (* (/ RA 180) pi) 24 | (vla-get-rotation OS) 25 | ) 26 | ) 27 | ); repeat 28 | (princ) 29 | ); defun C:RMB -------------------------------------------------------------------------------- /ssw.lsp: -------------------------------------------------------------------------------- 1 | ;; Select Similar within Window 2 | ;; Uses core SelectSimilar command 3 | ;; Alan J. Thompson, 2013.07.30 4 | ;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/select-similar-for-current-window-view/td-p/8480689 5 | 6 | (defun c:SSW (/ filter ss1 ss2 ss3 add i e) 7 | 8 | (setq filter (if (eq (getvar 'CVPORT) 1) 9 | (list (cons 410 (getvar 'CTAB))) 10 | '((410 . "Model")) 11 | ) 12 | ) 13 | (princ "\nSelect objects to select similar: ") 14 | (if (and (setq ss1 (ssget filter)) 15 | (progn (princ "\nSelect area to select similar object(s) within: ") 16 | (setq ss2 (ssget filter)) 17 | ) 18 | ) 19 | (progn (command "_.selectsimilar" ss1 "") 20 | (if (setq ss3 (ssget "_I" filter)) 21 | (progn (sssetfirst nil nil) 22 | (setq add (ssadd)) 23 | (repeat (setq i (sslength ss3)) 24 | (if (ssmemb (setq e (ssname ss3 (setq i (1- i)))) ss2) 25 | (setq add (ssadd e add)) 26 | ) 27 | ) 28 | (sssetfirst nil add) 29 | ) 30 | ) 31 | ) 32 | ) 33 | (princ) 34 | ) 35 | (c:ssw) 36 | -------------------------------------------------------------------------------- /LayerAll.lsp: -------------------------------------------------------------------------------- 1 | ;;; LayerAll.lsp 2 | ;;; This routine includes several commands to perform operations on all layers. 3 | 4 | ;;; The first command, "C:LAA", thaws, unlocks, and turns on all layers. 5 | (defun C:LAA (); Layers All All [Thawed, Unlocked, On] 6 | (command "_.layer" "_thaw" "" "_unlock" "" "on" "*" "" ".regen") 7 | (princ) 8 | ) 9 | 10 | ;;; The second command, "C:LAON", thaws and turns on all layers that are not locked. 11 | (defun C:LAON (); Layers All [Thawed and] On [not Unlocked] 12 | (command "_.layer" "thaw" "" "_on" "" "" ".regen") 13 | (princ) 14 | ) 15 | 16 | ;;; The third command, "C:LAOF", turns off all layers except the current layer. 17 | (defun C:LAOF (); Layers All Off [except current] 18 | (command "_.layer" "_off" "*" "_no" "") 19 | (princ) 20 | ) 21 | 22 | ;;; The fourth command, "C:LAF", freezes all layers except the current layer. 23 | (defun C:LAF (); Layers All Frozen [except current] 24 | (command "_.layer" "_freeze" "*" "_no" "") 25 | (princ) 26 | ) 27 | -------------------------------------------------------------------------------- /VCD.lsp: -------------------------------------------------------------------------------- 1 | ;: DEFUN is the function 2 | ;; C: tells autocad what the command is 3 | ;; VCD is the command to start the script 4 | ;; () indicates no local variables and no arguments 5 | ;; This routine cleans up a drawing by running and audit and a purge VCD (very clean drawing) 6 | (DEFUN C:VCD () 7 | (SETVAR "CMDECHO" 0);; turn echo off-turns off the read out of the following commands 8 | (command "AUDIT" "Y");; runs an audit to fix errors 9 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 10 | (repeat 2 ;; repeat following commands 2 times 11 | (command "-PURGE" "A" "*" "N");; purge drawing 12 | );; 13 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 14 | (command "imageframe" 0) 15 | (command "_.layer" "_set" "0" "") 16 | (command "imageframe" 1) 17 | (command "imageframe" 0) 18 | (command "ZOOM" "E");; zoom to extents 19 | (command "QSAVE");; quicksave 20 | (SETVAR "CMDECHO" 1);; turn echo on-turns on the read out of commands 21 | );;END DEFUN -------------------------------------------------------------------------------- /dwgClean.lsp: -------------------------------------------------------------------------------- 1 | ;: DEFUN is the function 2 | ;; C: tells autocad what the command is 3 | ;; VCD is the command to start the script 4 | ;; () indicates no local variables and no arguments 5 | ;; This routine cleans up a drawing by running and audit and a purge VCD (very clean drawing) 6 | (DEFUN C:VCD () 7 | (SETVAR "CMDECHO" 0);; turn echo off-turns off the read out of the following commands 8 | (command "AUDIT" "Y");; runs an audit to fix errors 9 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 10 | (repeat 2 ;; repeat following commands 2 times 11 | (command "-PURGE" "A" "*" "N");; purge drawing 12 | );; 13 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 14 | (command "imageframe" 0) 15 | (command "_.layer" "_set" "0" "") 16 | (command "imageframe" 1) 17 | (command "imageframe" 0) 18 | (command "ZOOM" "E");; zoom to extents 19 | (command "QSAVE");; quicksave 20 | (SETVAR "CMDECHO" 1);; turn echo on-turns on the read out of commands 21 | );;END DEFUN -------------------------------------------------------------------------------- /drawlines.lsp: -------------------------------------------------------------------------------- 1 | ;;;; This creates a group of lines with names of all the layers 2 | 3 | (defun c:drawlines ( / doc lyrs lst pt) 4 | ; Get the active document and all its layers 5 | (setq doc (vla-get-activedocument (vlax-get-acad-object)) 6 | lyrs (vla-get-layers doc) 7 | );end_setq 8 | ; Create a list of all layer names and sort it alphabetically 9 | (vlax-for lyr lyrs (setq lst (cons (vlax-get lyr 'name) lst))) 10 | (setq lst (vl-sort lst '< ) 11 | pt (getpoint "\nSelect insertion point: ") 12 | );end_setq 13 | ; Loop through each layer name and create a line and text entity for it 14 | (foreach lyr lst 15 | ; Create a line entity for the layer name 16 | (entmakex (list '(0 . "line") (cons 10 pt) (cons 11 (mapcar '+ pt '(2.5 0 0))) (cons 8 lyr))) 17 | ; Create a text entity for the layer name 18 | (entmakex (list '(0 . "text") (cons 10 (mapcar '+ pt '(3.0 0 0))) '(40 . 0.1) (cons 1 lyr) (cons 8 lyr))) 19 | ; Move the insertion point down for the next layer name 20 | (setq pt (mapcar '- pt '(0 0.15 0))) 21 | );end_foreach 22 | (princ) 23 | );end_defun 24 | -------------------------------------------------------------------------------- /PAO.LSP: -------------------------------------------------------------------------------- 1 | ;; To draw a Polyline of line segments with "A" option making pre- 2 | ;; defined arc segment of 180 degrees and 1-unit diameter, with 3 | ;; diameter as continuation of direction of previous line segment. 4 | ;; Kent Cooper, June 2011 5 | 6 | (defun C:PAO (/ pt1 pt2 pt3); = Polyline with Arc-Overs 7 | (setq 8 | pt1 (getpoint "\nStarting point: ") 9 | pt2 (getpoint pt1 "\nNext point: ") 10 | ); end setq 11 | (command "_.pline" pt1 pt2) 12 | (initget "Arc") 13 | (while 14 | (setq pt3 (getpoint pt2 "\nNext point or [Arc]: ")) 15 | (if (= pt3 "Arc") 16 | (command ; else - predefined arc segment 17 | "_arc" 18 | "_direction" 19 | (/ (* (+ (angle pt1 pt2) (/ pi 2)) 180) pi) 20 | (polar pt2 (angle pt1 pt2) 1) 21 | "_line" 22 | (setq 23 | pt1 (getvar 'lastpoint) 24 | pt2 (getpoint pt1 "\nNext point: ") 25 | ) 26 | ); end command 27 | (progn ; else - line segment 28 | (command pt3) 29 | (setq pt1 pt2 pt2 pt3); advance points 30 | ); end progn 31 | ); end if 32 | (initget "Arc") 33 | ); end while 34 | (command); end Polyline 35 | (princ) 36 | ); end defun -------------------------------------------------------------------------------- /vpfreeze.lsp: -------------------------------------------------------------------------------- 1 | (defun C:vpfreeze (/) 2 | (vl-load-com) 3 | (setq myvp (car (entsel "\nSelect viewport: "))) 4 | (setq myvp (vlax-ename->vla-object myvp)) 5 | (setq mylay (getstring "\nEnter layer name: ")) 6 | (vpfreeze myvp mylay) 7 | ) 8 | 9 | (defun vpfreeze (vp lay / typ val) 10 | (vla-getXdata vp "ACAD" 'typ 'val) 11 | (setq typ (reverse 12 | (cons 13 | 1002 14 | (cons 1002 15 | (cons 1003 (cddr (reverse (vlax-safearray->list typ)))) 16 | ) 17 | ) 18 | ) 19 | val (reverse 20 | (cons (vlax-make-variant "}") 21 | (cons (vlax-make-variant "}") 22 | (cons (vlax-make-variant lay) 23 | (cddr (reverse (vlax-safearray->list val))) 24 | ) 25 | ) 26 | ) 27 | ) 28 | ) 29 | (vla-setXData 30 | vp 31 | (vlax-safearray-fill 32 | (vlax-make-safearray 33 | vlax-vbInteger 34 | (cons 0 (1- (length typ))) 35 | ) 36 | typ 37 | ) 38 | (vlax-safearray-fill 39 | (vlax-make-safearray 40 | vlax-vbVariant 41 | (cons 0 (1- (length val))) 42 | ) 43 | val 44 | ) 45 | ) 46 | ;; this is needed to display the change 47 | (vla-display vp :vlax-false) 48 | (vla-display vp :vlax-true) 49 | ) -------------------------------------------------------------------------------- /textStyle.lsp: -------------------------------------------------------------------------------- 1 | 2 | ;;; Changes objects that are set to one text style to another text style. Both styles need to be defined in the drawing. 3 | ;;; Posted by Peter 4 | ;;; http://forums.augi.com/showthread.php?22959-Help-Changing-text-style-in-blocks 5 | ;;; 6 | ;;; Use the folowing format in the command line after loading the routine: 7 | ;;; (changestyle "oldtextstylename" "newtextstylename") 8 | ;;; 9 | (defun TextStyle (strStyle1 strStyle2 / entItem objBlock objDocument objItem ) 10 | (vl-load-com) 11 | (setq objDocument (vla-get-activedocument (vlax-get-acad-object))) 12 | (if (and (tblobjname "style" strStyle1) 13 | (tblobjname "style" strStyle2) 14 | ) 15 | (vlax-for objBlock (vla-get-blocks objDocument) 16 | (if (> (vla-get-count objBlock) 0) 17 | (progn 18 | (setq objItem (vla-item objBlock 0) 19 | entItem (vlax-vla-object->ename objItem) 20 | ) 21 | (while entItem 22 | (if (and (vlax-property-available-p (setq objItem (vlax-ename->vla-object entItem)) "StyleName") 23 | (= (strcase (vla-get-stylename objItem)) (strcase strStyle1)) 24 | ) 25 | (vla-put-stylename objItem strStyle2) 26 | ) 27 | (setq entItem (entnext entItem)) 28 | ) 29 | ) 30 | ) 31 | ) 32 | (princ "\nError check if styles exist: ") 33 | ) 34 | (vla-regen objDocument 0) 35 | ) 36 | -------------------------------------------------------------------------------- /clearwipeouts.lsp: -------------------------------------------------------------------------------- 1 | (vl-load-com) ; Load the Visual LISP extensions 2 | (defun c:ClearWipeouts (/ b o) ; Define a function named ClearWipeouts with two local variables b and o 3 | ;;--- Tharwat 26.June.2013 ---;; ; A comment indicating the author and date of the function 4 | (or doc ; If doc is nil, then 5 | (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) ; Set doc to the active document object 6 | ) 7 | (vlax-for b ; For each block b 8 | (vla-get-blocks ; Get the blocks collection 9 | doc ; From the document object 10 | ) 11 | (if ; If 12 | (and ; Both 13 | (eq :vlax-false (vla-get-isLayout b)) ; The block is not a layout 14 | (eq :vlax-false (vla-get-isXref b)) ; And the block is not an external reference 15 | ) 16 | (vlax-for o b ; For each object o in the block b 17 | (if (eq "AcDbWipeout" (vla-get-objectname o)) ; If the object is a wipeout 18 | (vl-catch-all-apply 'vla-delete (list o)) ; Delete the object using error handling 19 | ) 20 | ) 21 | ) 22 | ) 23 | 24 | (if (setq ss (ssget "_X" '((0 . "WIPEOUT")(410 . "Model")))) ; If a selection set of wipeouts in the model space is obtained 25 | (command "_.erase" ss "") ; Erase the selection set 26 | ) 27 | (vla-regen doc acAllViewports) ; Regenerate the document in all viewports 28 | (princ) ; Exit the function quietly 29 | ) 30 | -------------------------------------------------------------------------------- /MLeaderTextColor.lsp: -------------------------------------------------------------------------------- 1 | ; This routine changes the text color of multiple leaders 2 | ; Filename: MLeaderTextColor.lsp 3 | ; Author: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/multi-leader-object-text-color/m-p/6707419#M347290 4 | 5 | (vl-load-com) ; Load the Visual LISP extensions 6 | 7 | (defun c:MLeaderTextColor ( / col ss obj txt x y) 8 | 9 | (if (and (setq col (getint "\nText color number: ")) ; Prompt for the color number 10 | (setq ss (ssget '((0 . "MULTILEADER")))) ; Select the multileaders 11 | ) 12 | (repeat (setq i (sslength ss)) ; Loop through the selection set 13 | (setq obj (vlax-ename->vla-object (ssname ss (setq i (1- i)))) ; Get the multileader object 14 | txt (vla-get-TextString obj) ; Get the text string 15 | txt (vl-string-trim "{}" txt)) ; Remove the curly braces 16 | (foreach e '("\\C" "\\c") ; For each color escape sequence 17 | (while (and (setq x (vl-string-search e txt)) ; Find the start of the sequence 18 | (setq y (vl-string-search ";" txt x))) ; Find the end of the sequence 19 | (setq txt (strcat (substr txt 1 x) ; Concatenate the text without the sequence 20 | (substr txt (+ 2 y)))))) 21 | (vla-put-TextString obj (strcat "{\\C" (itoa col) ";" txt "}")) ; Set the text string with the new color 22 | )) 23 | (princ) ; Exit quietly 24 | ) 25 | -------------------------------------------------------------------------------- /changestyle.lsp: -------------------------------------------------------------------------------- 1 | ; This routine changes the style of all text and Mtext entities in the drawing to "iso" 2 | ; To run the routine, type "CHANGESTYLE" at the command line 3 | defun C:CHANGESTYLE (/ entities len count ent ent_data ent_name new_style_name) 4 | ; Set the default text style to "iso" with "isocp.shx" font 5 | (command "STYLE" "iso" "isocp.shx" "" "" "" "" "") 6 | ; Change the style of all TEXT entities to "iso" 7 | (setq entities (ssget "X" '((0 . "TEXT"))) 8 | len (sslength entities) 9 | count 0 10 | );setq 11 | 12 | (while (< count len) 13 | (setq ent (ssname entities count) 14 | ent_data (entget ent) 15 | ent_name (cdr (assoc 7 ent_data)) 16 | );setq 17 | 18 | (setq new_style_name (cons 7 "iso")) 19 | (setq ent_data (subst new_style_name (assoc 7 ent_data) ent_data)) 20 | (entmod ent_data) 21 | 22 | (setq count (+ count 1)) 23 | );while 24 | 25 | ;;;runs same routine again, picking up Mtext this time. 26 | ; Change the style of all MTEXT entities to "iso" 27 | (setq entities (ssget "X" '((0 . "MTEXT"))) 28 | len (sslength entities) 29 | count 0 30 | );setq 31 | 32 | (while (< count len) 33 | (setq ent (ssname entities count) 34 | ent_data (entget ent) 35 | ent_name (cdr (assoc 7 ent_data)) 36 | );setq 37 | 38 | (setq new_style_name (cons 7 "iso")) 39 | (setq ent_data (subst new_style_name (assoc 7 ent_data) ent_data)) 40 | (entmod ent_data) 41 | 42 | (setq count (+ count 1)) 43 | );while 44 | 45 | (princ) 46 | 47 | );defun 48 | -------------------------------------------------------------------------------- /dwgCAD.lsp: -------------------------------------------------------------------------------- 1 | ;; Cleans up drawing to create a CAD file 2 | (DEFUN C:CAD () 3 | (SETVAR "CMDECHO" 0);; turn echo off-turns off the read out of the following commands 4 | (command "_.layer" "_set" "0" "") 5 | (command "-layer" "Thaw" "*" "ON" "*" "UNLOCK" "*" "S" "0" "") ;; thaws, turns on and unlocks all layers then sets the current layer to 0 6 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 7 | (command "AUDIT" "Y");; runs an audit to fix errors 8 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 9 | (repeat 4 ;; repeat following commands 4 times 10 | (command "-overkill" all "" "");; overkill everything 11 | );; 12 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 13 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 14 | (repeat 4 ;; repeat following commands 2 times 15 | (command "-PURGE" "A" "*" "N");; purge drawing 16 | );; 17 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 18 | 19 | (if (and ;if 20 | (tblsearch "LAYER" "*REV*") ;exists and 21 | (not (ssget "X" '((8 . "*REV*")))) ;is empty and 22 | (/= (getvar "CLAYER") "*REV*") ;not current 23 | ) ;then 24 | (command "_PURGE" "_LAY" "*REV*" "_NO");purge 25 | ) 26 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 27 | 28 | (command "ZOOM" "E");; zoom to extents 29 | (command "QSAVE");; quicksave 30 | (SETVAR "CMDECHO" 1);; turn echo on-turns on the read out of commands 31 | );;END DEFUN -------------------------------------------------------------------------------- /rcpClean.lsp: -------------------------------------------------------------------------------- 1 | (DEFUN C:RCP () 2 | (SETVAR "CMDECHO" 0);; turn echo off-turns off the read out of the following commands 3 | (command "AUDIT" "Y");; runs an audit to fix errors 4 | (command "imageframe" 1) 5 | (command "imageframe" 0) 6 | (command "_.layer" "_set" "0" "") 7 | (command "-layer" "Thaw" "*" "ON" "*" "UNLOCK" "*" "S" "0" "") ;; thaws, turns on and unlocks all layers then sets the current layer to 0 8 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 9 | (while (ssget "X" '((0 . "INSERT"))) ;; bursts all blocks in drawing. Checks to see if there are any in the drawing after 10 | (sssetfirst nil (ssget "X" (list ))) 11 | (c:burst) 12 | ); end while 13 | ;;delete specific layers 14 | (command "-laydel" "name" "A-WALL" "" "Y") 15 | (command "-laydel" "name" "A-DOOR" "" "Y") 16 | (command "-laydel" "name" "I-WALL" "" "Y") 17 | (command "-laydel" "name" "Q-CASE" "" "Y") 18 | (command "-laydel" "name" "Q-SPCQ" "" "Y") 19 | (command "-laydel" "name" "Q-CASE-HDLN" "" "Y") 20 | (command "-laydel" "name" "A-GLAZ" "" "Y") 21 | (command "-laydel" "name" "A-GLAZ-CURT" "" "Y") 22 | (command "-laydel" "name" "A-GLAZ-CWMG" "" "Y") 23 | (command "-laydel" "name" "A-AREA-IDEN" "" "Y") 24 | ;; end delete specific layers 25 | ;;(repeat 2 ;; repeat following commands 2 times 26 | (command "-PURGE" "A" "*" "N");; purge drawing 27 | );; 28 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 29 | (command "ZOOM" "E");; zoom to extents 30 | (command "AUDIT" "Y");; runs an audit to fix errors 31 | (command "QSAVE");; quicksave 32 | (SETVAR "CMDECHO" 1);; turn echo on-turns on the read out of commands 33 | );;END DEFUN -------------------------------------------------------------------------------- /NOZ.LSP: -------------------------------------------------------------------------------- 1 | ;Jeff Clark last modified 10/08/03 2 | ;Changes "Z" elevations of LINES and ARCS and POLYLINES to "0.0"; 3 | ; 4 | (defun C:NOZ (/ SS1 SS2 CNT1 CNT2 CNT3 ENT ED A B C D E F) 5 | 6 | (setq SS1 (ssget "X" '((0 . "line")))) 7 | (setq CNT1 (sslength ss1)) 8 | (setq CNT2 0) 9 | (setq CNT3 0) 10 | (setq counter 0) 11 | (while (< CNT2 CNT1) 12 | (setq ENT (ssname SS1 CNT3)) 13 | (setq ED (entget ENT)) 14 | (setq A (cdr (assoc 10 ED))) 15 | (setq B (subst 0.0 (caddr A) A)) 16 | (setq ED (subst (cons 10 B) (assoc 10 ED) ED)) 17 | (entmod ED) 18 | (setq C (cdr (assoc 11 ED))) 19 | (setq D (subst 0.0 (caddr C) C)) 20 | (setq ED (subst (cons 11 D) (assoc 11 ED) ED)) 21 | (entmod ED) 22 | (entupd ENT) 23 | (setq CNT2 (+ CNT2 1)) 24 | (setq CNT3 (+ CNT3 1)) 25 | (setq counter (+ counter 1)) 26 | ) 27 | (setq SS2 (ssget "X" '((0 . "arc")))) 28 | (setq CNT1 (sslength SS2)) 29 | (setq CNT2 0) 30 | (setq CNT3 0) 31 | (while (< CNT2 CNT1) 32 | (setq ENT (ssname SS2 CNT3)) 33 | (setq ED (entget ENT)) 34 | (setq E (cdr (assoc 10 ED))) 35 | (setq F (subst 0.0 (caddr E) E)) 36 | (setq ED (subst (cons 10 F) (assoc 10 ED) ED)) 37 | (entmod ED) 38 | (entupd ENT) 39 | (setq CNT2 (+ CNT2 1)) 40 | (setq CNT3 (+ CNT3 1)) 41 | (setq counter (+ counter 1)) 42 | ) 43 | (setq SS2 (ssget "X" '((0 . "LWPOLYLINE")))) 44 | (setq CNT1 (sslength SS2)) 45 | (setq CNT2 0) 46 | (setq CNT3 0) 47 | (while (< CNT2 CNT1) 48 | (setq ENT (ssname SS2 CNT3)) 49 | (setq ED (entget ENT)) 50 | (setq E (assoc 38 ED)) 51 | (setq ED (subst (cons 38 0.0) (assoc 38 ED) ED)) 52 | (entmod ED) 53 | (entupd ENT) 54 | (setq CNT2 (+ CNT2 1)) 55 | (setq CNT3 (+ CNT3 1)) 56 | (setq counter (+ counter 1)) 57 | ) 58 | (prompt (strcat (rtos counter 2 0) " Entities Checked or Changed")) 59 | (princ) 60 | ) -------------------------------------------------------------------------------- /ALLOWEXPLODEBLOCKS.lsp: -------------------------------------------------------------------------------- 1 | ;*********************************************************** 2 | ;** ** 3 | ;** Purpose: This routine allows the user to explode all ** 4 | ;** blocks in the current drawing, including ** 5 | ;** those that are not set as explodable. ** 6 | ;** ** 7 | ;** Usage: Type "expl-p" to run the routine. ** 8 | ;** ** 9 | ;*********************************************************** 10 | ; 11 | ; Load the ActiveX Automation Library to work with VLA objects 12 | ; 13 | ; Loop through all the blocks in the current drawing 14 | ; - Get the current drawing's active document using vlax-get-acad-object and vla-get-ActiveDocument 15 | ; - Get all the blocks in the current drawing using vla-get-Blocks and the previously obtained active document 16 | ; - Check if the block name matches the pattern for a space character or if it is not set as explodable 17 | ; - Set the block as explodable if it was not explodable before 18 | ; 19 | ; End the loop through all the blocks. 20 | ; 21 | ; Return control to the command line using the princ function. 22 | 23 | ; Allows the exploding of all blocks 24 | ; Type "expl-p" to run 25 | (defun c:expl-p () 26 | ; Load the ActiveX Automation Library to work with VLA objects 27 | (vl-load-com) 28 | 29 | ; Loop through all the blocks in the current drawing 30 | (vlax-for block (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) 31 | ; Check if the block name matches the pattern for a space character or if it is not set as explodable 32 | (or (wcmatch (vla-get-Name block) "`**_Space*") 33 | (vla-put-explodable block :vlax-true) 34 | ) 35 | ) 36 | 37 | ; Return control to the command line 38 | (princ) 39 | ) 40 | -------------------------------------------------------------------------------- /MultipleXr.lsp: -------------------------------------------------------------------------------- 1 | ;;; Attach Xref to all drawings in Folder , RLX 6-Feb-2019 2 | (defun c:RlxFaXref (/ _getfolder app adoc odbs odbx v xref folder dwg xr) 3 | (vl-load-com) 4 | (defun _getfolder ( m / sh f r ) 5 | (setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application") f (vlax-invoke-method sh 'browseforfolder 0 m 0)) 6 | (vlax-release-object sh)(if f (progn (setq r (vlax-get-property (vlax-get-property f 'self) 'path))(if (wcmatch r "*\\") r (strcat r "\\"))))) 7 | ; i is 0 (absolute), 1 (relative) of 2 (no) -xref path 8 | (defun RLXref_SetPathType (i) 9 | (vl-registry-write (strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Profiles\\" (getvar "cprofile") "\\Dialogs\\XattachDialog") "PathType" i)) 10 | (setq odbs "ObjectDBX.AxDbDocument" v (substr (getvar 'acadver) 1 2) adoc (vla-get-activedocument (setq app (vlax-get-acad-object)))) 11 | (RLXref_SetPathType 1) 12 | (cond 13 | ((vl-catch-all-error-p (setq odbx (vl-catch-all-apply 'vla-getinterfaceobject (list app (if (< (atoi v) 16) odbs (strcat odbs "." v)))))) 14 | (princ "\nObject DBX interface not created!")) 15 | ((not (setq xref (getfiled "Select Xref to attach" "" "dwg" 0))) (alert "No Xref was selected")) 16 | ((setq folder (_getfolder "Select folder with drawings to attach xref to")) 17 | (foreach dwg (vl-directory-files folder "*.dwg" 0) 18 | (setq dwg (strcat folder dwg)) 19 | (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list odbx dwg))) 20 | (princ (strcase (strcat "\nError opening: " dwg))) 21 | (progn 22 | (princ (strcat "\nOpening: " dwg)) 23 | ; attach xref 24 | (if (vl-catch-all-error-p (setq xr (vl-catch-all-apply 'vla-AttachExternalReference 25 | (list (vla-get-ModelSpace odbx) xref (vl-filename-base xref) (vlax-3d-point 0 0 0) 1 1 1 0 :vlax-false)))) 26 | (princ (vl-catch-all-error-message xr))) 27 | ; save drawing 28 | (vla-saveas odbx (vla-get-name odbx)) 29 | ) 30 | ) 31 | ) 32 | ) 33 | ) 34 | (princ) 35 | ) -------------------------------------------------------------------------------- /ReplaceTXTwBlock.lsp: -------------------------------------------------------------------------------- 1 | 2 | ;;;; This replaces txt with a block with an attribute tag 3 | (defun c:Txt2Blk (/ T2B_Selection T2B_Baseblock T2B_AttributeTag T2B_ActiveLayout T2B_ActiveDoc T2B_Text T2B_Block) 4 | (setq T2B_Baseblock "ANNO-13A") 5 | (setq T2B_AttributeTag "CH1") 6 | (if 7 | (and 8 | (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list (vla-get-Blocks (setq T2B_ActiveDoc (vla-get-ActiveDocument (vlax-get-acad-object)))) T2B_Baseblock)))) 9 | (setq T2B_Selection (ssget '((0 . "*TEXT")))) 10 | ) 11 | (progn 12 | (setq T2B_ActiveLayout (vla-get-Block (vla-get-ActiveLayout T2B_ActiveDoc))) 13 | (vla-StartUndoMark T2B_ActiveDoc) 14 | (foreach T2B_Text (mapcar 'cadr (ssnamex T2B_Selection)) 15 | (if 16 | (= (type T2B_Text) 'ENAME) 17 | (progn 18 | (setq T2B_Text (vlax-ename->vla-object T2B_Text)) 19 | (setq T2B_Block (vla-InsertBlock T2B_ActiveLayout (vla-get-InsertionPoint T2B_Text) T2B_Baseblock 1 1 1 0)) 20 | (PushAttValue T2B_Block (list (list T2B_AttributeTag (vla-get-TextString T2B_Text)))) 21 | (vla-Delete T2B_Text) 22 | ) 23 | ) 24 | ) 25 | (vla-EndUndoMark T2B_ActiveDoc) 26 | (vlax-release-object T2B_ActiveLayout) 27 | ) 28 | ) 29 | (vlax-release-object T2B_ActiveDoc) 30 | (princ) 31 | ) 32 | 33 | (defun PushAttValue (PAV_BlkObject PAV_TagValList / PAV_AttList) 34 | (if 35 | (and 36 | (= (type PAV_BlkObject) 'VLA-OBJECT) 37 | (= (vla-get-ObjectName PAV_BlkObject) "AcDbBlockReference") 38 | (= (vla-get-HasAttributes PAV_BlkObject) :vlax-true) 39 | ) 40 | (progn 41 | (setq PAV_AttList (vlax-safearray->list (vlax-variant-value (vla-GetAttributes PAV_BlkObject)))) 42 | (foreach PAV_Item PAV_AttList 43 | (vl-catch-all-apply 'vla-put-TextString (list PAV_Item (cadr (assoc (strcase (vla-get-TagString PAV_Item)) PAV_TagValList)))) 44 | ) 45 | ) 46 | ) 47 | ) 48 | -------------------------------------------------------------------------------- /blkto0.lsp: -------------------------------------------------------------------------------- 1 | ; Define a command named C:BLKTO0 with local variables idx, lst, and sel 2 | (defun c:blkto0 ( / idx lst sel ) 3 | ; If a selection set of blocks is obtained 4 | (if (setq sel (ssget '((0 . "INSERT")))) 5 | ; Repeat for each block in the selection set 6 | (repeat (setq idx (sslength sel)) 7 | ; Call the BLOCK->0 command with the block name as argument 8 | (block->0 (cdr (assoc 2 (entget (ssname sel (setq idx (1- idx))))))) 9 | ) 10 | ) 11 | ; Regenerate the drawing 12 | (command "_.regen") 13 | ; Exit quietly 14 | (princ) 15 | ) 16 | 17 | ; Define a command named BLOCK->0 with local variables blk, ent, and enx 18 | (defun block->0 ( blk / ent enx ) 19 | ; Check two conditions 20 | (cond 21 | ; If the block name is not in the list 22 | ( (member blk lst)) 23 | ; Then do the following 24 | ( ; Get the block definition entity from the block name 25 | (setq ent (tblobjname "block" blk)) 26 | ; While there is another entity in the block definition 27 | (while (setq ent (entnext ent)) 28 | ; Modify the entity to change its layer and color to 0 29 | (entmod (subst-append 8 "0" (subst-append 62 256 (setq enx (entget ent))))) 30 | ; If the entity is a nested block 31 | (if (= "INSERT" (cdr (assoc 0 enx))) 32 | ; Then call the BLOCK->0 command with the nested block name as argument 33 | (block->0 (cdr (assoc 2 enx))) 34 | ) 35 | ) 36 | ; Add the block name to the list 37 | (setq lst (cons blk lst)) 38 | ) 39 | ) 40 | ) 41 | 42 | ; Define a helper function named SUBST-APPEND with local variables key, val, lst, and itm 43 | (defun subst-append ( key val lst / itm ) 44 | ; If the key is found in the list 45 | (if (setq itm (assoc key lst)) 46 | ; Then replace the value with the new value 47 | (subst (cons key val) itm lst) 48 | ; Else append the key-value pair to the list 49 | (append lst (list (cons key val))) 50 | ) 51 | ) -------------------------------------------------------------------------------- /breakAtIntersection.lsp: -------------------------------------------------------------------------------- 1 | ;; Run the routine by the command BE 2 | ;; This routine breaks a line at a specified gap distance. 3 | ;; To use it enter the distance desired and select the point at intersection then select the line to use to break with. 4 | (Defun C:BE (/ s1 obj ds pr PT1 PT2 )(vl-load-com) 5 | (setq s1 (getvar "osmode")) ;; find the current osmode of drawing 6 | (setq gap (cond 7 | ((getdist (strcat "\nEnter distance" 8 | (if gap (strcat " <" (rtos gap) ">: ") ": ") 9 | )))(gap)) 10 | ) 11 | (setvar osmode 2048) 12 | (setq PT1 (getpoint "\nPick central point to trim:")) ;; select a central point 13 | (setq obj (car (entsel "\nSelect object to trim:"))) ;; select the objects to trim 14 | (setq ds (vlax-curve-getDistAtPoint obj (vlax-curve-getclosestpointto obj PT1))) 15 | (setq pr (vlax-curve-getParamAtPoint obj (vlax-curve-getclosestpointto obj PT1))) 16 | ;; break the line at the specific point selected at a distance given by 0.5 units 17 | (command "_break" obj "_non" (vlax-curve-getPointAtDist obj (+ ds (* gap 0.5))) 18 | "_non" (vlax-curve-getPointAtDist obj (- ds (* gap 0.5)))) 19 | (setvar "osmode" s1) ;; set the osmode back to the original osmode of the drawing 20 | (princ) 21 | ) 22 | 23 | ;; Definitions below 24 | ;; Variables: s1, obj, ds, pr, PT1, PT2, gap 25 | ;; s1: finds the "osmode" current snap point 26 | ;; gap: specify the distance of the break 27 | ;; PT1: the intersection of where to trim 28 | ;; osmode: snap point 29 | ;; strcat Returns a string that is the concatenation of multiple strings 30 | ;; entsel: A prompt string to be displayed to users. If omitted, entsel prompts with the message, "Select object." 31 | ;; setq: Sets the value of a symbol or symbols to associated expressions 32 | ;; princ: Prints an expression to the command line, or writes an expression to an open file 33 | ;; car: Returns the first element of a list unless empty then returns "nil" 34 | ;; vlax-curve-getDistAtPoint: Returns the length of the curve's segment between the curve's start point and the specified point 35 | ;; vlax-curve-getParamAtPoint: Returns the parameter of the curve at the point -------------------------------------------------------------------------------- /dwgFOO.lsp: -------------------------------------------------------------------------------- 1 | ;: DEFUN is the function 2 | ;; C: tells autocad what the command is 3 | ;; FOO is the command to start the script 4 | ;; () indicates no local variables and no arguments 5 | ;; This cleans up the drawing by thawing and making all layers visible, then bursting all blocks in the drawing. 6 | ;; Only use the bursting section for smaller drawings. It will take a while on larger ones. 7 | ;; Overkills any overlap after the bursting 8 | ;; Resets the layer properties to "ByLayer" 9 | ;; Audits the drawing 10 | ;; Purgest the drawing twice 11 | ;; Zooms to extents then saves 12 | ;; Pauses during each command to allow for processing 13 | (defun C:FOO () 14 | (SETVAR "CMDECHO" 0);; turn echo off-turns off the read out of the following commands 15 | (command "-layer" "Thaw" "*" "ON" "*" "UNLOCK" "*" "S" "0" "") ;; thaws, turns on and unlocks all layers then sets the current layer to 0 16 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 17 | (while (ssget "X" '((0 . "INSERT"))) ;; bursts all blocks in drawing. Checks to see if there are any in the drawing after 18 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 19 | (sssetfirst nil (ssget "X" (list ))) 20 | (c:burst) 21 | ); end while 22 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 23 | (if (setq ss (ssget "_X" '((0 . "HATCH")))) ;; delete all hatches 24 | (command "_.hatchgenerateboundary" ss "" 25 | "_.erase" ss "")) ;; delete all hatch boundaries 26 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 27 | (repeat 4 ;; repeat following commands 4 times 28 | (command "-overkill" all "" "");; overkill everything 29 | );; 30 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 31 | (command "AUDIT" "Y");; runs an audit to fix errors 32 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 33 | (while (= 1 (getvar "cmdactive")) (command pause)) ;; pauses while command is active 34 | (repeat 2 ;; repeat following commands 2 times 35 | (command "-PURGE" "A" "*" "N");; purge drawing 36 | );; 37 | (command "ZOOM" "E");; zoom to extents 38 | (command "QSAVE");; quicksave 39 | (SETVAR "CMDECHO" 1);; turn echo on-turns on the read out of commands 40 | (princ) 41 | );;END DEFUN 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # AutoCAD-Scripts 2 | A collection of helpful AutoCAD scripts used to speed up the set up process and overall design of projects. 3 | Also included is a dwg file for dynamic MEP blocks 4 | 5 | DrawingScales.xlsx 6 | A list of view port scaling key factors 7 | 8 | Dynamic Blocks and Such 9 | A series of MEP and Architectural dynamic blocks 10 | 11 | ExportToAutoCAD 12 | A simple script that exports the drawing 13 | 14 | ImageFrameRemoval 15 | Easy fix for the "Image Frame Bug" 16 | 17 | allowexplodeblocks 18 | Allows all blocks in a drawings to be burstable/exploadable 19 | 20 | changeColors 21 | This is a script that will thaw and unhide all layers then change the layer colors. This is purely an example of how to write the 22 | script. Layer colors can be anything. You can even change linetype with this example. 23 | 24 | continuosarc 25 | Creates a way to make arcs continuously. 26 | 27 | continuousLine 28 | Creates a way to make lines continuously. Different from a polyline. 29 | 30 | deleteAroundArea 31 | This allows you to create a box and everything outside this box will be deleted 32 | 33 | drawlines 34 | Draws lines for all layers of a drawing 35 | 36 | portme 37 | Lisp routine similar to the script "ExportToAutocad" which allows you to export the existing drawing to a 2013 38 | 39 | rename-multiple-files 40 | This is a simple batch file that can rename files in a folder 41 | 42 | rotateMultipleBlocks 43 | Select specific block and you can rotate them around their basepoint 44 | 45 | setup 46 | This is a tool that preps a CAD base file to be used for MEP drawing. It clears useless data within the file making it a smaller size. 47 | 48 | breakAtIntersection 49 | This routine breaks a line at a specified gap distance. 50 | To use it enter the distance desired and select the point at intersection then select the line to use to break with. 51 | 52 | dwgFoo 53 | This cleans up the drawing by thawing and making all layers visible, then bursting all blocks in the drawing. 54 | Only use the bursting section for smaller drawings. It will take a while on larger ones. 55 | Overkills any overlap after the bursting 56 | Resets the layer properties to "ByLayer" 57 | Audits the drawing 58 | Purgest the drawing twice 59 | Zooms to extents then saves 60 | Pauses during each command to allow for processing 61 | 62 | dwgClean 63 | This routine cleans up a drawing by running and audit and a purge VCD (very clean drawing) 64 | -------------------------------------------------------------------------------- /ScaleAboutCenters.lsp: -------------------------------------------------------------------------------- 1 | ;; ScaleAboutCenters.lsp [command name: SAC] 2 | ;; To Scale multiple objects, each About its own Center, by the same User-specified 3 | ;; scale factor. 4 | ;; Uses the middle of each object's bounding box as the base point for scaling, to 5 | ;; keep objects centered at approximately the same position in the drawing. 6 | ;; [For Mtext, that will be based on the defined Mtext box width, not the extents 7 | ;; of the content; for a Block or Text, the center of its extents in the drawing, not 8 | ;; its insertion point; for an Arc, the center of its extents, not its geometric center; 9 | ;; some entity types' (e.g. Spline's) bounding box can sometimes reach beyond 10 | ;; its extents and affect results slightly.] 11 | ;; Rejects selection of objects on locked Layers, or without a "center" [Rays, Xlines]. 12 | ;; Stores scale factor; offers as default on subsequent use in same editing session. 13 | ;; Kent Cooper, 6 May 2014 14 | 15 | (defun C:SAC (/ *error* cmde ss inc ent) 16 | (defun *error* (errmsg) 17 | (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break")) 18 | (princ (strcat "\nError: " errmsg)) 19 | ); end if 20 | (command "_.undo" "_end") 21 | (setvar 'cmdecho cmde) 22 | (princ) 23 | ); end defun - *error* 24 | (setq cmde (getvar 'cmdecho)) 25 | (setvar 'cmdecho 0) 26 | (command "_.undo" "_begin") 27 | (setq *SACscl 28 | (cond 29 | ( (getreal 30 | (strcat 31 | "\nEnter Scale Factor <" 32 | (if *SACscl (rtos *SACscl 2 4) "1"); offer default: prior value / 1 on first use 33 | ">: " 34 | ); strcat 35 | ); getreal 36 | ); User-input condition 37 | (*SACscl); Enter on subsequent use [prior value] 38 | (1); Enter on first use 39 | ); cond & *SACscl 40 | ss (ssget ":L" '((-4 . ""))) 41 | ;; not objects on Locked Layers or without finite extents 42 | ); setq 43 | (repeat (setq inc (sslength ss)) 44 | (setq ent (ssname ss (setq inc (1- inc)))) 45 | (vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt) 46 | (command 47 | ".scale" ent "" "_none" 48 | (mapcar '/ ; midpoint of bounding box 49 | (mapcar '+ (vlax-safearray->list minpt) (vlax-safearray->list maxpt)) 50 | '(2 2 2) 51 | ); mapcar 52 | *SACscl 53 | ); command 54 | ); repeat 55 | (command "_.undo" "_end") 56 | (setvar 'cmdecho cmde) 57 | (princ) 58 | ); defun 59 | (vl-load-com) 60 | (prompt "\nType SAC to Scale objects About each one's Center.") -------------------------------------------------------------------------------- /RB.lsp: -------------------------------------------------------------------------------- 1 | (vl-load-com) 2 | 3 | (defun c:RB () (c:ReplaceBlock)) 4 | (defun c:ReplaceBlock (/ *error* blockName ok acDoc space ss oBlock) 5 | 6 | (defun *error* (msg) 7 | (if ss (vla-delete ss)) 8 | (if acDoc 9 | (vla-endundomark acDoc) 10 | ) 11 | (cond ((not msg)) ; Normal exit 12 | ((member msg '("Function cancelled" "quit / exit abort"))) ; or (quit) 13 | ((princ (strcat "\n** Error: " msg " ** "))) ; Fatal error, display it 14 | ) 15 | (princ) 16 | ) 17 | 18 | (if 19 | (and 20 | (ssget "_:L" '((0 . "INSERT"))) 21 | (or (/= "" 22 | (setq blockName 23 | (strcase 24 | (getstring 25 | T 26 | (strcat "\nEnter replacement block name" 27 | (if *ReplaceBlockName* 28 | (strcat " <" *ReplaceBlockName* ">: ") 29 | ": " 30 | ) 31 | ) 32 | ) 33 | ) 34 | ) 35 | ) 36 | (setq blockName *ReplaceBlockName*) 37 | ) 38 | (setq *ReplaceBlockName* blockName) 39 | (or (and (tblsearch "block" blockName) (setq ok T)) 40 | (setq blockName (findfile (strcat blockName ".dwg"))) 41 | ) 42 | ) 43 | (progn 44 | (vla-startundomark 45 | (setq acDoc (vla-get-activedocument (vlax-get-acad-object))) 46 | ) 47 | (setq space (vlax-get acDoc 48 | (if (= 1 (getvar 'cvport)) 49 | 'paperspace 50 | 'modelspace 51 | ) 52 | ) 53 | ) 54 | (vlax-for x (setq ss (vla-get-activeselectionset acDoc)) 55 | (vla-put-layer 56 | (setq oBlock (vla-insertblock 57 | space 58 | (vla-get-insertionpoint x) 59 | blockName 60 | (vla-get-xscalefactor x) 61 | (vla-get-yscalefactor x) 62 | (vla-get-zscalefactor x) 63 | (vla-get-rotation x) 64 | ) 65 | ) 66 | (vla-get-layer x) 67 | ) 68 | (vla-put-color oBlock (vla-get-color x)) 69 | (vla-delete x) 70 | (if (not ok) 71 | (progn 72 | (setq blockName (vl-filename-base blockName)) 73 | (setq ok T) 74 | ) 75 | ) 76 | ) 77 | ) 78 | ) 79 | (*error* nil) 80 | ) -------------------------------------------------------------------------------- /mhatch.lsp: -------------------------------------------------------------------------------- 1 | ``` 2 | This function, `c:mhatch`, creates a hatch pattern for selected entities in AutoCAD. It first checks if the selected entities are either a LWPOLYLINE, POLYLINE, CIRCLE, or ELLIPSE. If the entity is a closed polyline, a circle, or a closed curve, it creates a hatch using the current system variables for hatch pattern name, scale, and angle. The hatch is created in either the model space or paper space depending on the current viewport. The function then prints a newline character to the command line. This function is a great example of how to use AutoLISP to automate tasks in AutoCAD. 3 | 4 | ``` 5 | 6 | (defun c:mhatch (/ ang do-it doc hatch oname pname scl space ss) 7 | ; Check if the user has selected any entities of type LWPOLYLINE, POLYLINE, CIRCLE, or ELLIPSE 8 | (if (setq ss (ssget '((0 . "LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")))) 9 | (progn 10 | ; Get the current system variables for hatch pattern scale, angle, and name 11 | (setq scl (getvar "hpscale") ; Hatch pattern scale 12 | ang (getvar "hpang") ; Hatch pattern angle 13 | pname (getvar "hpname") ; Hatch pattern name 14 | ; Check if hatch patterns are associative 15 | hpassoc (if (= (getvar "hpassoc") 1) 16 | :vlax-true 17 | :vlax-false) 18 | ; Get the active document 19 | doc (vla-get-activedocument 20 | (vlax-get-acad-object)) 21 | ; Check if the current viewport is paper space or model space 22 | space (if (= (getvar "cvport") 1) 23 | (vla-get-paperspace doc) 24 | (vla-get-modelspace doc) 25 | ) 26 | ) 27 | ; Loop through each entity in the active selection set 28 | (vlax-for ent (vla-get-activeselectionset doc) 29 | (setq do-it nil 30 | ; Get the name of the entity 31 | oname (strcase (vla-get-objectname ent))) 32 | ; Check the type and properties of the entity 33 | (cond ((vl-string-search "CIRCLE" oname) ; If the entity is a circle 34 | (setq do-it t) 35 | ) 36 | ((and (vl-string-search "LINE" oname) ; If the entity is a closed polyline 37 | (eq (vla-get-closed ent) :vlax-true) 38 | ) 39 | (setq do-it t) 40 | ) 41 | ((equal (vlax-curve-getstartpoint ent) ; If the entity is a closed curve 42 | (vlax-curve-getendpoint ent) 43 | 1e-6) 44 | (setq do-it t) 45 | ) 46 | ) 47 | ; If the entity meets the conditions, create a hatch 48 | (if do-it 49 | (progn 50 | ; Create a new hatch in the current space 51 | (setq hatch (vlax-invoke space 'addhatch acHatchObject pname hpassoc)) 52 | ; Add the entity to the hatch 53 | (vlax-invoke hatch 'appendouterloop (list ent)) 54 | ; Set the hatch pattern angle and scale 55 | (vlax-put hatch 'patternangle ang) 56 | (vlax-put hatch 'patternscale scl) 57 | ; Evaluate the hatch to display it 58 | (vla-evaluate hatch) 59 | ) 60 | ) 61 | ) 62 | ) 63 | ) 64 | ; Print a newline character to the command line 65 | (princ) 66 | ) -------------------------------------------------------------------------------- /changeLayoutNames.lsp: -------------------------------------------------------------------------------- 1 | (defun c:changeLayoutNames ( / idx lst lyc obj pre srt suf num ) 2 | (vlax-for lay (setq lyc (vla-get-layouts (vla-get-activedocument (vlax-get-acad-object)))) 3 | (if (= :vlax-false (vla-get-modeltype lay)) 4 | (setq lst (cons (vla-get-name lay) lst) 5 | srt (cons (vla-get-taborder lay) srt) 6 | obj (cons lay obj) 7 | ) 8 | ) 9 | ) 10 | (if (setq 11 | pre (getstring t "\nSpecify prefix : ") 12 | suf (getstring T "\nSpecify suffix : ") 13 | num (1- (cond ((getint "\nSpecify starting number <1>: "))(1))) 14 | srt (vl-sort-i srt '<) 15 | obj (mapcar '(lambda ( n ) (nth n obj)) srt) 16 | idx (LM:listbox "Select Layouts to Rename" (mapcar '(lambda ( n ) (nth n lst)) srt) 3) 17 | ) 18 | (progn 19 | ;; Temporary rename to free up keys held by other layouts in the selection 20 | (foreach n idx (vla-put-name (nth n obj) (vla-get-handle (nth n obj)))) 21 | (foreach n idx (vla-put-name (nth n obj) (getname lyc pre suf num))) 22 | ) 23 | ) 24 | (princ) 25 | ) 26 | (defun getname ( lyc pre suf int / int rtn ) 27 | (while 28 | (not 29 | (vl-catch-all-error-p 30 | (vl-catch-all-apply 'vla-item 31 | (list lyc 32 | (setq int (1+ int) 33 | rtn (strcat pre (if (< 9 int) (itoa int) (strcat "0" (itoa int)))suf) 34 | ) 35 | ) 36 | ) 37 | ) 38 | ) 39 | ) 40 | rtn 41 | ) 42 | 43 | ;; List Box - Lee Mac 44 | ;; Displays a DCL list box allowing the user to make a selection from the supplied data. 45 | ;; msg - [str] Dialog label 46 | ;; lst - [lst] List of strings to display 47 | ;; bit - [int] 1=allow multiple; 2=return indexes 48 | ;; Returns: [lst] List of selected items/indexes, else nil 49 | 50 | (defun LM:listbox ( msg lst bit / dch des tmp rtn ) 51 | (cond 52 | ( (not 53 | (and 54 | (setq tmp (vl-filename-mktemp nil nil ".dcl")) 55 | (setq des (open tmp "w")) 56 | (write-line 57 | (strcat "listbox:dialog{label=\"" msg "\";spacer;:list_box{key=\"list\";multiple_select=" 58 | (if (= 1 (logand 1 bit)) "true" "false") ";width=50;height=15;}spacer;ok_cancel;}" 59 | ) 60 | des 61 | ) 62 | (not (close des)) 63 | (< 0 (setq dch (load_dialog tmp))) 64 | (new_dialog "listbox" dch) 65 | ) 66 | ) 67 | (prompt "\nError Loading List Box Dialog.") 68 | ) 69 | ( t 70 | (start_list "list") 71 | (foreach itm lst (add_list itm)) 72 | (end_list) 73 | (setq rtn (set_tile "list" "0")) 74 | (action_tile "list" "(setq rtn $value)") 75 | (setq rtn 76 | (if (= 1 (start_dialog)) 77 | (if (= 2 (logand 2 bit)) 78 | (read (strcat "(" rtn ")")) 79 | (mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" rtn ")"))) 80 | ) 81 | ) 82 | ) 83 | ) 84 | ) 85 | (if (< 0 dch) 86 | (unload_dialog dch) 87 | ) 88 | (if (and tmp (setq tmp (findfile tmp))) 89 | (vl-file-delete tmp) 90 | ) 91 | rtn 92 | ) 93 | 94 | (vl-load-com) (princ) -------------------------------------------------------------------------------- /fixLeader.lsp: -------------------------------------------------------------------------------- 1 | ;; This program creates multileaders with reversed text and deletes selected text 2 | ;; It uses the vlax and vla objects to manipulate the text and multileader entities 3 | (defun c:am (/ newleader pt1 pt2 ss txt x w rjp-getbbwdth) ; Define a function with the name am and some local variables 4 | (vl-load-com) ; Load the Visual LISP COM support 5 | ;; define function to get bounding box width 6 | (defun rjp-getbbwdth (obj / out ll ur) ; Define a function with the name rjp-getbbwdth and some local variables 7 | (vla-getboundingbox obj 'll 'ur) ; Get the bounding box of the given object and store the lower-left and upper-right corners 8 | (setq out (mapcar 'vlax-safearray->list (list ll ur))) ; Convert the corners to lists and store them in out 9 | (distance (car out) (list (caadr out) (cadar out))) ; Calculate and return the distance between the x-coordinates of the corners 10 | ) 11 | (if (setq ss (ssget '((0 . "*TEXT")))) ; If there are any text entities in the drawing, select them and store them in ss 12 | ;; get text content and width 13 | (progn ; Begin a series of expressions 14 | (setq txt (apply ; Apply a function to a list of arguments 15 | 'strcat ; The function is strcat, which concatenates strings 16 | (mapcar ; Apply a function to each element of a list 17 | 'cdr ; The function is cdr, which returns the rest of a list 18 | (vl-sort ; Sort a list according to a comparison function 19 | (mapcar ; Apply a function to each element of a list 20 | '(lambda (x) ; The function is a lambda expression that takes one argument x 21 | (cons ; Create a cons cell 22 | (vlax-get x 'insertionpoint) ; The car of the cons cell is the insertion point of the text entity 23 | (strcat (vlax-get x 'textstring) " ") ; The cdr of the cons cell is the text string of the text entity with a space added 24 | ) 25 | ) 26 | (setq ; Assign a value to a variable 27 | ss (mapcar ; Apply a function to each element of a list 28 | 'vlax-ename->vla-object ; The function is vlax-ename->vla-object, which converts an entity name to a VLA object 29 | (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) ; The list is the result of removing any sublist from the list of entity names in the selection set 30 | ) 31 | ) 32 | ) 33 | ) 34 | (function (lambda (y1 y2) (< (cadr (car y2)) (cadr (car y1)))) ; The comparison function is a lambda expression that compares the y-coordinates of the insertion points 35 | ) 36 | ) 37 | ) 38 | ) 39 | w (car (vl-sort (mapcar 'rjp-getbbwdth ss) '>)) ; Get the maximum bounding box width of the text entities 40 | txt (apply 'strcat ; Apply a function to a list of arguments 41 | (mapcar 'chr (reverse (cdr (reverse (vl-string->list txt))))) ; The list is the result of reversing the characters of the concatenated text string 42 | ) 43 | ) 44 | ;; delete selected text 45 | (mapcar 'vla-delete ss) ; Delete all the text entities in the selection set 46 | ) 47 | ) 48 | (if (and (setq pt1 (getpoint "\nSpecify leader arrowhead location: ")) ; If the user specifies a point for the leader arrowhead 49 | (setq pt2 (getpoint pt1 "\nSpecify landing location: ")) ; And the user specifies a point for the landing location 50 | ) 51 | ;; create multileader entity 52 | (progn ; Begin a series of expressions 53 | (command "._MLEADER" pt1 pt2 "") ; Create a multileader entity with the given points 54 | ;; reverse text and set width 55 | (setq newleader (vlax-ename->vla-object (entlast))) ; Get the VLA object of the multileader entity 56 | (vla-put-textstring newleader txt) ; Set the text string of the multileader entity to the reversed text 57 | (vla-put-textwidth newleader w) ; Set the text width of the multileader entity to the maximum width 58 | ) 59 | ) 60 | (princ) ; Exit the function quietly 61 | ) 62 | -------------------------------------------------------------------------------- /circlewidth.lsp: -------------------------------------------------------------------------------- 1 | ; Written By: Jason Piercey 07.31.01 2 | ; Revised: 01.16.02 To handle multiple selection 3 | ; This function converts circles to lightweight polylines 4 | (defun C:Circle2Pline (/ CirEnt CirElst CirCen CirRad CirLay 5 | CirLin CirClr CirLts PlineEnt ss 6 | i );ss1) 7 | 8 | (setq ss (ssget '((0 . "CIRCLE")))) ; Select all circles in the drawing 9 | (if ss ; If the selection set is not empty 10 | (progn ; Begin a series of expressions 11 | (setq i 0 );ss1 (ssadd)) ; Initialize a counter variable 12 | (repeat (sslength ss) ; Loop through each circle in the selection set 13 | (setq CirEnt (ssname ss i) ; Get the entity name of the circle 14 | CirElst (entget CirEnt) ; Get the entity data of the circle 15 | CirCen (cdr (assoc 10 CirElst)) ; Get the center point of the circle 16 | CirRad (cdr (assoc 40 CirElst)) ; Get the radius of the circle 17 | CirLay (cdr (assoc 8 CirElst)) ; Get the layer of the circle 18 | CirLin (cdr (assoc 6 CirElst)) ; Get the linetype of the circle 19 | CirClr (cdr (assoc 62 CirElst)) ; Get the color of the circle 20 | CirLts (cdr (assoc 48 CirElst)) ; Get the linetype scale of the circle 21 | ) 22 | 23 | (setq PlineEnt (list '(0 . "LWPOLYLINE") ; Create a list of entity data for the polyline 24 | '(100 . "AcDbEntity") 25 | (cons 8 CirLay) ; Set the layer of the polyline to the same as the circle 26 | '(100 . "AcDbPolyline") 27 | '(90 . 2) ; Set the number of vertices to 2 28 | '(70 . 1) ; Set the closed flag to 1 29 | '(43 . 0.0) ; Set the constant width to 0.0 30 | '(38 . 0.0) ; Set the elevation to 0.0 31 | '(39 . 0.0) ; Set the thickness to 0.0 32 | (cons 10 (polar CirCen (* pi) CirRad)) ; Set the first vertex to the top of the circle 33 | '(40 . 0.0) ; Set the starting width to 0.0 34 | '(41 . 0.0) ; Set the ending width to 0.0 35 | '(42 . 1.0) ; Set the bulge to 1.0 36 | (cons 10 (polar CirCen (* pi 2.0) CirRad)) ; Set the second vertex to the bottom of the circle 37 | '(40 . 0.0) ; Set the starting width to 0.0 38 | '(41 . 0.0) ; Set the ending width to 0.0 39 | '(42 . 1.0) ; Set the bulge to 1.0 40 | '(210 0.0 0.0 1.0) ; Set the normal vector to the Z-axis 41 | ) 42 | ) 43 | 44 | (if CirLin (setq PlineEnt (append PlineEnt (list (cons 6 CirLin))))) ; If the circle has a linetype, set the polyline to the same 45 | (if CirClr (setq PlineEnt (append PlineEnt (list (cons 62 CirClr))))) ; If the circle has a color, set the polyline to the same 46 | (if CirLts (setq PlineEnt (append PlineEnt (list (cons 48 CirLts))))) ; If the circle has a linetype scale, set the polyline to the same 47 | (entmake PlineEnt) ; Create the polyline entity 48 | (entdel CirEnt) ; Delete the circle entity 49 | (setq i (1+ i)) ; Increment the counter variable 50 | ) 51 | ) 52 | ) 53 | ;(ssget "p") ; This line is commented out 54 | (princ (strcat "\n"(itoa i) " Circles converted to LwPolylines")) ; Print the number of circles converted 55 | (princ) ; Exit the function quietly 56 | ) 57 | -------------------------------------------------------------------------------- /xxx.lsp: -------------------------------------------------------------------------------- 1 | ;;Please feel free to rename these commands as you desire. 2 | (defun c:xxx () (section t nil)); SECTION W/ BORDER 3 | 4 | * * * * * ERROR ROUTINE * * * * * 5 | (defun newerr (msg) 6 | (prompt (strcat "\nSection cancelled: " msg)); PRINT ERROR 7 | (setvar "cmdecho" cmd); RESET COMMAND ECHO 8 | (setvar "highlight" hlt); RESET HIGHLIGHT 9 | ) 10 | 11 | 12 | * * * * * MAIN FUNCTION * * * * * 13 | ;If the first argument has any value other than nil then the border will be left. If it is nil 14 | ;then the border is erased. 15 | ;If the second argument is has any value other than nil then entities inside the border will be erased. 16 | ;If it is nil then entities outside the border are erase. 17 | ;For very large area drawings (maps or something), the DST variable may need to be changed. If you 18 | ;find that not all entities are being trimmed properly try increasing the number higher than 1000. 19 | 20 | (defun section (bdr n / olderr newerr cmd hlt p1 p2 p1x p1y p2x p2y p3 p4 dst plus minus p1a p2a p3a p4a lst) 21 | (graphscr); CHANGE TO GRAPHICS SCREEN 22 | (setq olderr *error* ; SET UP NEW 23 | *error* newerr ; ERROR ROUTINE 24 | cmd (getvar "cmdecho"); SAVE COMMAND ECHO SETTING 25 | hlt (getvar "highlight"); SAVE HIGHLIGHT SETTING 26 | p1 (getpoint "\nSelect first corner of rectangle: "); GET LL CORNER OF RECTANGLE 27 | p2 (getcorner p1 "\nSelect other corner: "); GET UR CORNER 28 | p1x (car p1) 29 | p1y (cadr p1) 30 | p2x (car p2) 31 | p2y (cadr p2) 32 | p3 (list p2x p1y); BUILD LR CORNER 33 | p4 (list p1x p2y); BUILD UL CORNER 34 | dst (/ (distance p1 p2) 1000.0); OFFSET FACTOR FOR TRIMMING 35 | plus (if n - +) 36 | minus (if n + -) 37 | );END SETQ 38 | (cond 39 | ((and (< p1x p2x) (< p1y p2y)); P1 IS LL CORNER 40 | (setq p1a (list (minus p1x dst) (minus p1y dst)); BUILD LL TRIM LINE POINT 41 | p2a (list (plus p2x dst) (plus p2y dst))); BUILD UR TRIM LINE POINT 42 | ) 43 | ((and (> p1x p2x) (< p1y p2y)); P1 IS UL CORNER 44 | (setq p1a (list (plus p1x dst) (minus p1y dst)); BUILD LL TRIM LINE POINT 45 | p2a (list (minus p2x dst) (plus p2y dst))); BUILD UR TRIM LINE POINT 46 | ) 47 | ((and (> p1x p2x) (> p1y p2y)); P1 IS UR CORNER 48 | (setq p1a (list (plus p1x dst) (plus p1y dst)); BUILD LL TRIM LINE POINT 49 | p2a (list (minus p2x dst) (minus p2y dst))); BUILD UR TRIM LINE POINT 50 | ) 51 | ((and (< p1x p2x) (> p1y p2y)); P1 IS LR CORNER 52 | (setq p1a (list (minus p1x dst) (plus p1y dst)); BUILD LL TRIM LINE POINT 53 | p2a (list (plus p2x dst) (minus p2y dst))); BUILD UR TRIM LINE POINT 54 | ) 55 | ); END COND 56 | (setq p3a (list (car p2a) (cadr p1a)); BUILD LR TRIM LINE POINT 57 | p4a (list (car p1a) (cadr p2a)); BUILD UL TRIM LINE POINT 58 | ); END SETQ 59 | (setvar "cmdecho" 0); TURN OFF COMMAND ECHO 60 | (setvar "highlight" 0); TURN OFF HIGHLIGHT 61 | 62 | (if n ;ERASE ENTITIES 63 | (command "_.erase" "_w" p1 p2 "_r" lst "") ;INSIDE RECTANGLE 64 | (command "_.erase" "_all" "_r" "_c" p1 p2 "") ;OUTSIDE RECTANGLE 65 | ); END IF 66 | (command "_.trim" lst "" "_f" p1a p3a "" ;TRIM ENTITIES AROUND BORDER 67 | "_f" p3a p2a "" ;DO TO THE FINICKY NATURE OF TRIMMING 68 | "_f" p2a p4a "" ;WITH THE FENCE OPTION, I HAVE USED FOUR 69 | "_f" p4a p1a "" "" ;FENCE LINES INSTEAD OF ONE LONG ONE 70 | ); END COMMAND 71 | (command "ZOOM" "E") ;; zoom to extents 72 | (command "QSAVE") ;; quicksave 73 | (if (not bdr) (entdel lst)); DELETE POLYLINE BORDER IF DESIRED 74 | (setq *error* olderr); RESTORE ORIGINAL ERROR ROUTINE 75 | (setvar "highlight" hlt); RESTORE HIGHLIGHT 76 | (setvar "cmdecho" cmd); RESTORE COMMAND ECHO 77 | (princ); EXIT CLEANLY 78 | ) -------------------------------------------------------------------------------- /deleteAroundArea.lsp: -------------------------------------------------------------------------------- 1 | ;;Please feel free to rename these commands as you desire. 2 | (defun c:xxx () (section t nil)); SECTION W/ BORDER 3 | 4 | * * * * * ERROR ROUTINE * * * * * 5 | (defun newerr (msg) 6 | (prompt (strcat "\nSection cancelled: " msg)); PRINT ERROR 7 | (setvar "cmdecho" cmd); RESET COMMAND ECHO 8 | (setvar "highlight" hlt); RESET HIGHLIGHT 9 | ) 10 | 11 | 12 | * * * * * MAIN FUNCTION * * * * * 13 | ;If the first argument has any value other than nil then the border will be left. If it is nil 14 | ;then the border is erased. 15 | ;If the second argument is has any value other than nil then entities inside the border will be erased. 16 | ;If it is nil then entities outside the border are erase. 17 | ;For very large area drawings (maps or something), the DST variable may need to be changed. If you 18 | ;find that not all entities are being trimmed properly try increasing the number higher than 1000. 19 | 20 | (defun section (bdr n / olderr newerr cmd hlt p1 p2 p1x p1y p2x p2y p3 p4 dst plus minus p1a p2a p3a p4a lst) 21 | (graphscr); CHANGE TO GRAPHICS SCREEN 22 | (setq olderr *error* ; SET UP NEW 23 | *error* newerr ; ERROR ROUTINE 24 | cmd (getvar "cmdecho"); SAVE COMMAND ECHO SETTING 25 | hlt (getvar "highlight"); SAVE HIGHLIGHT SETTING 26 | p1 (getpoint "\nSelect first corner of rectangle: "); GET LL CORNER OF RECTANGLE 27 | p2 (getcorner p1 "\nSelect other corner: "); GET UR CORNER 28 | p1x (car p1) 29 | p1y (cadr p1) 30 | p2x (car p2) 31 | p2y (cadr p2) 32 | p3 (list p2x p1y); BUILD LR CORNER 33 | p4 (list p1x p2y); BUILD UL CORNER 34 | dst (/ (distance p1 p2) 1000.0); OFFSET FACTOR FOR TRIMMING 35 | plus (if n - +) 36 | minus (if n + -) 37 | );END SETQ 38 | (cond 39 | ((and (< p1x p2x) (< p1y p2y)); P1 IS LL CORNER 40 | (setq p1a (list (minus p1x dst) (minus p1y dst)); BUILD LL TRIM LINE POINT 41 | p2a (list (plus p2x dst) (plus p2y dst))); BUILD UR TRIM LINE POINT 42 | ) 43 | ((and (> p1x p2x) (< p1y p2y)); P1 IS UL CORNER 44 | (setq p1a (list (plus p1x dst) (minus p1y dst)); BUILD LL TRIM LINE POINT 45 | p2a (list (minus p2x dst) (plus p2y dst))); BUILD UR TRIM LINE POINT 46 | ) 47 | ((and (> p1x p2x) (> p1y p2y)); P1 IS UR CORNER 48 | (setq p1a (list (plus p1x dst) (plus p1y dst)); BUILD LL TRIM LINE POINT 49 | p2a (list (minus p2x dst) (minus p2y dst))); BUILD UR TRIM LINE POINT 50 | ) 51 | ((and (< p1x p2x) (> p1y p2y)); P1 IS LR CORNER 52 | (setq p1a (list (minus p1x dst) (plus p1y dst)); BUILD LL TRIM LINE POINT 53 | p2a (list (plus p2x dst) (minus p2y dst))); BUILD UR TRIM LINE POINT 54 | ) 55 | ); END COND 56 | (setq p3a (list (car p2a) (cadr p1a)); BUILD LR TRIM LINE POINT 57 | p4a (list (car p1a) (cadr p2a)); BUILD UL TRIM LINE POINT 58 | ); END SETQ 59 | (setvar "cmdecho" 0); TURN OFF COMMAND ECHO 60 | (setvar "highlight" 0); TURN OFF HIGHLIGHT 61 | 62 | (if n ;ERASE ENTITIES 63 | (command "_.erase" "_w" p1 p2 "_r" lst "") ;INSIDE RECTANGLE 64 | (command "_.erase" "_all" "_r" "_c" p1 p2 "") ;OUTSIDE RECTANGLE 65 | ); END IF 66 | (command "_.trim" lst "" "_f" p1a p3a "" ;TRIM ENTITIES AROUND BORDER 67 | "_f" p3a p2a "" ;DO TO THE FINICKY NATURE OF TRIMMING 68 | "_f" p2a p4a "" ;WITH THE FENCE OPTION, I HAVE USED FOUR 69 | "_f" p4a p1a "" "" ;FENCE LINES INSTEAD OF ONE LONG ONE 70 | ); END COMMAND 71 | (command "ZOOM" "E") ;; zoom to extents 72 | (command "QSAVE") ;; quicksave 73 | (if (not bdr) (entdel lst)); DELETE POLYLINE BORDER IF DESIRED 74 | (setq *error* olderr); RESTORE ORIGINAL ERROR ROUTINE 75 | (setvar "highlight" hlt); RESTORE HIGHLIGHT 76 | (setvar "cmdecho" cmd); RESTORE COMMAND ECHO 77 | (princ); EXIT CLEANLY 78 | ) 79 | -------------------------------------------------------------------------------- /replaceBlock.lsp: -------------------------------------------------------------------------------- 1 | ; Load the Visual LISP COM support 2 | (vl-load-com) 3 | 4 | ; Define a function RB that calls another function ReplaceBlock 5 | (defun c:RB () (c:ReplaceBlock)) 6 | 7 | ; Define a function ReplaceBlock that takes no arguments 8 | (defun c:ReplaceBlock (/ *error* blockName ok acDoc space ss oBlock) 9 | 10 | ; Define an error handler function that takes a message argument 11 | (defun *error* (msg) 12 | (if ss (vla-delete ss)) ; If the selection set exists, delete it 13 | (if acDoc 14 | (vla-endundomark acDoc) ; If the active document exists, end the undo mark 15 | ) 16 | (cond ((not msg)) ; Normal exit 17 | ((member msg '("Function cancelled" "quit / exit abort"))) ; or (quit) 18 | ((princ (strcat "\n** Error: " msg " ** "))) ; Fatal error, display it 19 | ) 20 | (princ) ; Exit the function quietly 21 | ) 22 | 23 | ; If the following conditions are met 24 | (if 25 | (and 26 | (ssget "_:L" '((0 . "INSERT"))) ; Select all the block references in the drawing 27 | (or (/= "" 28 | (setq blockName 29 | (strcase 30 | (getstring 31 | T 32 | (strcat "\nEnter replacement block name" 33 | (if *ReplaceBlockName* 34 | (strcat " <" *ReplaceBlockName* ">: ") 35 | ": " 36 | ) 37 | ) 38 | ) 39 | ) 40 | ) 41 | ) 42 | (setq blockName *ReplaceBlockName*) ; Use the previous block name if any 43 | ) 44 | (setq *ReplaceBlockName* blockName) ; Store the block name in a global variable 45 | (or (and (tblsearch "block" blockName) (setq ok T)) ; Check if the block name exists in the block table 46 | (setq blockName (findfile (strcat blockName ".dwg"))) ; Or find the block name as a dwg file 47 | ) 48 | ) 49 | (progn ; Begin a series of expressions 50 | (vla-startundomark 51 | (setq acDoc (vla-get-activedocument (vlax-get-acad-object))) ; Get the active document object and start an undo mark 52 | ) 53 | (setq space (vlax-get acDoc 54 | (if (= 1 (getvar 'cvport)) ; Check if the current viewport is paper space 55 | 'paperspace ; Get the paper space object 56 | 'modelspace ; Get the model space object 57 | ) 58 | ) 59 | ) 60 | (vlax-for x (setq ss (vla-get-activeselectionset acDoc)) ; Loop through each block reference in the selection set 61 | (vla-put-layer 62 | (setq oBlock (vla-insertblock ; Insert a new block reference 63 | space ; In the current space 64 | (vla-get-insertionpoint x) ; At the same insertion point as the original block 65 | blockName ; With the replacement block name 66 | (vla-get-xscalefactor x) ; With the same x scale factor as the original block 67 | (vla-get-yscalefactor x) ; With the same y scale factor as the original block 68 | (vla-get-zscalefactor x) ; With the same z scale factor as the original block 69 | (vla-get-rotation x) ; With the same rotation as the original block 70 | ) 71 | ) 72 | (vla-get-layer x) ; Set the layer of the new block to the same as the original block 73 | ) 74 | (vla-put-color oBlock (vla-get-color x)) ; Set the color of the new block to the same as the original block 75 | (vla-delete x) ; Delete the original block 76 | (if (not ok) ; If the block name was not found in the block table 77 | (progn 78 | (setq blockName (vl-filename-base blockName)) ; Get the base name of the block file 79 | (setq ok T) ; Set the flag to true 80 | ) 81 | ) 82 | ) 83 | ) 84 | ) 85 | (*error* nil) ; Call the error handler function with no message 86 | ) 87 | --------------------------------------------------------------------------------