diff --git a/README.md b/README.md index 8a31e03..394c6d0 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ # lisp-scr -My lisp and acad scripts \ No newline at end of file +My lisp and acad scripts. + +Scripts in downloaded folder are not my work, they are from the internet. \ No newline at end of file diff --git a/allToZero.lsp b/allToZero.lsp new file mode 100644 index 0000000..a639063 --- /dev/null +++ b/allToZero.lsp @@ -0,0 +1,29 @@ +(defun C:alltozero (/ i imax il ss currElem currPos newPos newElem) + ;variables: + (setq i 0);counter to zero + (setq imax 1);while variable + + (graphscr) + + (setq ss (ssget "_A" '((0 . "insert"))));select all + (setq il (sslength ss));length of selection + + (while imax + + (setq currElem (entget (ssname ss i) )) + (setq currPos (assoc 10 currElem)) + + ;; (cdr (assoc 10 currElem)) + + (setq newPos (list 10 0 0 0)) + + (setq newElem (subst newPos currPos currElem)) + (entmod newElem) + + + ;while specific: + (setq i (1+ i));increments i + (if (= i il) (setq imax nil));finish function if i equals il + ) + +) diff --git a/autosave.lsp b/autosave.lsp new file mode 100644 index 0000000..38b19e2 --- /dev/null +++ b/autosave.lsp @@ -0,0 +1 @@ +(setvar "SAVETIME" 15) \ No newline at end of file diff --git a/bindImages.lsp b/bindImages.lsp new file mode 100644 index 0000000..0baad36 --- /dev/null +++ b/bindImages.lsp @@ -0,0 +1,40 @@ +(defun C:bindimages (/ i imax il ss currElem currPos newPos newElem) + ;variables: + (setq i 0);counter to zero + (setq imax 1);while variable + + (graphscr) + + (setq ss (ssget "_A" '((0 . "insert"))));select all + (setq il (sslength ss));length of selection + + (while imax + + (setq currElem (entget (ssname ss i) )) + (setq currPos (assoc 10 currElem)) + + ;; (cdr (assoc 10 currElem)) + + (setq newPos (list 10 0 0 0)) + + (setq newElem (subst newPos currPos currElem)) + (entmod newElem) + + + ;while specific: + (setq i (1+ i));increments i + (if (= i il) (setq imax nil));finish function if i equals il + ) + + + + + + + + + + + + +) diff --git a/blockbase.lsp b/blockbase.lsp new file mode 100644 index 0000000..1e77c6e --- /dev/null +++ b/blockbase.lsp @@ -0,0 +1,9 @@ +(defun C:bb (/ ss newpoint goodpoint) + (graphscr) + (prompt "\nselect entities to move (all): ") + (setq ss (ssget));asks for selection + (setq newpoint (getpoint "\nPick new basepoint")) + (setq goodpoint(subst 0.0 (nth 2 newpoint) newpoint)) + (print goodpoint) + (command "._move" ss "" "_non" goodpoint "_non" "0,0,0") +) \ No newline at end of file diff --git a/blockpres.lsp b/blockpres.lsp new file mode 100644 index 0000000..8aa067f --- /dev/null +++ b/blockpres.lsp @@ -0,0 +1,123 @@ +;;blockpres.lsp +;; +;;Routine for block presentation in a file. It sorts the selected blocks in alphabetical order, and align them to a nice grid. +;; +;; Created by Peter Gyetvai +;; gyetpet@gmail.com +;; gyetvai-peter.hu + + +(defun C:blockpres (/ i imax j jmax ss goodsel colnr il jl distance currSel currElem newElem currTyp currPos currName currColNr currRowNr nameList nameListOrder currOrder) + ;variables: + (setq i 0);counter to zero + (setq imax 1);while variable + + (setq j 0);counter to zero + (setq jmax 1);while variable + + (setq currColNr 0) + (setq currRowNr 0) + + (setq nameList ()) + (setq goodsel (ssadd)) + + (vl-load-com) + (graphscr) + + (prompt "\nSelect blocks: [All]") + (setq ss (ssget));asks for selection + (setq jl (sslength ss));length of selection + (setq distance (getdist "\nDistance between blocks? ")) + (setq colnr (getint "\nNumber of columns? ")) + + ;; gets the blocks name + (while jmax + (print ) + (princ "Checking element ") + (princ (1+ j)) + (princ "/") + (princ jl) + + (setq currSel (ssname ss j)) + (setq currElem (entget currSel)) + (setq currName (cdr (assoc 2 currElem))) + (setq currTyp (cdr (assoc 0 currElem))) + (princ " - type: ") + (princ currTyp) + + ;; checks if it's a block + (cond + ( + (= currTyp "INSERT");if block + (progn + (princ " - name: ") + (princ currName) + + (setq nameList (append nameList (list (strcase currName)))) + ;; (print nameList) + (ssadd currSel goodsel) + ) + ) + ( + (not (= currTyp "INSERT"));if not block + (progn + (princ ": This is not a block") + ) + ) + ) + ;while specific: + (setq j (1+ j));increments j + (if (= j jl) (setq jmax nil));finish function if j equals jl + ) + + + ;; sorts the block names + (setq nameListOrder (vl-sort-i nameList '<)) + + ;; length of new selection set + (setq il (sslength goodsel)) + (print ) + + ;; Modify coordinates + (while imax + (print ) + (princ "Moving element ") + (princ (1+ i)) + (princ "/") + (princ il) + + (setq currOrder (nth i nameListOrder)) + + + (setq currElem (entget (ssname goodsel currOrder) )) + (setq currPos (assoc 10 currElem)) + + (princ " - block name: ") + (princ (cdr (assoc 2 currElem))) + (print ) + + (setq newPos (list 10 (* currColNr distance) (* currRowNr distance) 0)) + + (setq newElem (subst newPos currPos currElem)) + (entmod newElem) + + ;; ATTSYNC + (command "._ATTSYNC" "N" (cdr (assoc 2 currElem))) + + ;; change col and row numbers + (setq currColNr (1+ currColNr)) + (if (= currColNr colnr) + (progn + (setq currRowNr (1+ currRowNr)) + (setq currColNr 0) + ) + ) + + ;while specific: + (setq i (1+ i));increments i + (if (= i il) (setq imax nil));finish function if i equals il + ) + + (setq ss nil) + (princ) +) diff --git a/dimMeter.lsp b/dimMeter.lsp new file mode 100644 index 0000000..f2e75fe --- /dev/null +++ b/dimMeter.lsp @@ -0,0 +1,51 @@ +(defun C:dimmeter (/ allelems goodStyleElem goodStyleList goodStyleType goodStyle ii imax ilength currElem currLength currStyle newStyle newElem) + + (setq goodStyleElem (entsel "Select dimension with meter based dimstyle: ")) + (setq goodStyleList (entget (car goodStyleElem))) + (setq goodStyleType (cdr(assoc 0 goodStyleList))) + (setq goodStyle (cdr(assoc 3 goodStyleList))) + (princ "\nSelected dimstyle: " ) + (princ goodStyle) + + (if (wcmatch goodStyleType "DIMENSION") + (progn + + (setq imax 1);while variable + (setq ii 0);counter to zero + + (setq allelems (ssget "x" '((0 . "DIMENSION")))) + (setq ilength (sslength allelems)) + ;; (print ilength) + + (while imax + (print ii) + (setq currElem (entget (ssname allelems ii))) + (setq currLength (cdr (assoc 42 currElem))) + (setq currStyle (cdr (assoc 3 currElem)));; current dimension style + ;; (print currLength) + + (if (wcmatch currStyle goodStyle) + (print currStyle) + + (if (> currLength 100) + (progn + (setq newStyle(cons 3 goodStyle)) + (setq newElem(subst newStyle (assoc 3 currElem) currElem)) + (entmod newElem) + ) + + ) + ) + + ;while specific: + (setq ii (1+ ii));increments i + (if (= ii ilength) (setq imax nil));finish function if i equals il + ) + + ) + + (princ "\nThat's not a dimension. Please select a dimension!");;else + ) + (setq allelems nil) + (setq goodStyleElem nil) +) diff --git a/downloaded/ArcToLine.lsp b/downloaded/ArcToLine.lsp new file mode 100644 index 0000000..fcb8a44 --- /dev/null +++ b/downloaded/ArcToLine.lsp @@ -0,0 +1,106 @@ +(defun c:ArcToLine (/ *error* blg blk ent objts cnt blgLoc pts stp mxp cur + ent2d) + (vl-load-com) + (defun *error* (msg) + (and uFlag (vla-EndUndoMark doc)) + (and ov (mapcar (function setvar) vl ov)) + (and msg + (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") + (princ (strcat "\n** Error: " msg " **")) + ) + ) + (princ) + ) + (defun blg (ent num / blg) + (repeat num + (setq blg (cons (list + (vla-getbulge ent (setq num (1- num))) + (trans (vlax-safearray->list + (variant-value + (vla-Get-coordinate ent num) + ) + ) + 0 + 1 + ) + ) + blg + ) + ) + ) + + ) + (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)) + vl '("CMDECHO" "OSMODE" "ORTHOMODE") + ov (mapcar (function getvar) vl) + ) + (prompt "\nSelect LWPOLYLINE To convert:") + (if + (and + (setq uFlag (not (vla-StartUndoMark doc))) + (mapcar (function setvar) vl '(0 0 0)) + (setq pts nil ent (car (entsel "\nSelect Polyline Boundary:\n"))) + (eq (cdr (assoc 0 (entget ent))) "LWPOLYLINE") + (setq alen (getdist "\nEnter line ncrement length: ")) + ) + (progn + (setq objts (vlax-ename->vla-object ent)) + (setq cnt 0 + blgLoc (blg objts (cdr (assoc 90 (entget ent)))) + ) + (foreach itm blgLoc + (setq cnt (1+ cnt)) + (if (= (car itm) 0.0) + (setq pts (cons (trans (cadr itm) 1 0) pts)) + (progn + (setq pts (cons (trans (cadr itm) 1 0) pts)) + (setq stp (if (zerop + (setq cur (vlax-curve-getDistAtPoint + objts + (trans (cadr itm) 1 0) + ) + ) + ) + (vla-get-length objts) + cur + ) + nxp (if (>= (1+ cnt) (cdr (assoc 90 (entget ent)))) + (vla-get-length objts) + (vlax-curve-getDistAtPoint + objts + (trans (cadr (nth cnt blgLoc)) 1 0) + ) + ) + ) + (while (< (setq stp (+ stp alen)) nxp) + (setq + pts (cons (vlax-curve-getPointAtDist objts stp) pts) + ) + ) + ) + ) + ) + clr + (if pts + (progn + (setq + ent2d (entmakex + (append + (list (cons 0 "LWPOLYLINE") + (cons 100 "AcDbEntity") + (cons 100 "AcDbPolyline") + (cons 90 (length pts)) + (cons 70 0) + ) + (mapcar (function (lambda (p) (cons 10 p))) pts) + ) + ) + )(entdel ent) + ) + ) + (setq uFlag (vla-EndUndoMark doc)) + ) + ) + (*error* nil) + (princ) +) \ No newline at end of file diff --git a/downloaded/Blockreplace.lsp b/downloaded/Blockreplace.lsp new file mode 100644 index 0000000..62a687c --- /dev/null +++ b/downloaded/Blockreplace.lsp @@ -0,0 +1,90 @@ +(defun c:BRE (/ *error* blk f ss temp) + ;; Replace multiple instances of selected blocks (can be different) with selected block + ;; Size and Rotation will be taken from original block and original will be deleted + ;; Required subroutines: AT:GetSel + ;; Alan J. Thompson, 02.09.10 + + (vl-load-com) + + (defun *error* (msg) + (and f *AcadDoc* (vla-endundomark *AcadDoc*)) + (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,"))) + (princ (strcat "\nError: " msg)) + ) + ) + + (if + (and + (AT:GetSel + entsel + "\nSelect replacement block: " + (lambda (x / e) + (if + (and + (eq "INSERT" (cdr (assoc 0 (setq e (entget (car x)))))) + (/= 4 (logand (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 e))))) 4)) + (/= 4 (logand (cdr (assoc 70 (entget (tblobjname "LAYER" (cdr (assoc 8 e)))))) 4)) + ) + (setq blk (vlax-ename->vla-object (car x))) + ) + ) + ) + (princ "\nSelect blocks to be repalced: ") + (setq ss (ssget "_:L" '((0 . "INSERT")))) + ) + (progn + (setq f (not (vla-startundomark + (cond (*AcadDoc*) + ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))) + ) + ) + ) + ) + (vlax-for x (setq ss (vla-get-activeselectionset *AcadDoc*)) + (setq temp (vla-copy blk)) + (mapcar (function (lambda (p) + (vl-catch-all-apply + (function vlax-put-property) + (list temp p (vlax-get-property x p)) + ) + ) + ) + '(Insertionpoint Rotation XEffectiveScaleFactor YEffectiveScaleFactor + ZEffectiveScaleFactor + ) + ) + (vla-delete x) + ) + (vla-delete ss) + (*error* nil) + ) + ) + (princ) +) + +(defun AT:GetSel (meth msg fnc / ent good) + ;; meth - selection method (entsel, nentsel, nentselp) + ;; msg - message to display (nil for default) + ;; fnc - optional function to apply to selected object + ;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (x) (eq (cdr (assoc 0 (entget (car x)))) "ARC"))) + ;; Alan J. Thompson, 05.25.10 + (setvar 'errno 0) + (while (not good) + (setq ent (meth (cond (msg) + ("\nSelect object: ") + ) + ) + ) + (cond + ((vl-consp ent) + (setq good (cond ((or (not fnc) (fnc ent)) ent) + ((prompt "\nInvalid object!")) + ) + ) + ) + ((eq (type ent) 'STR) (setq good ent)) + ((setq good (eq 52 (getvar 'errno))) nil) + ((eq 7 (getvar 'errno)) (setq good (prompt "\nMissed, try again."))) + ) + ) +) \ No newline at end of file diff --git a/downloaded/ChangeBlockBasePointV1-5.lsp b/downloaded/ChangeBlockBasePointV1-5.lsp new file mode 100644 index 0000000..7fb11c8 --- /dev/null +++ b/downloaded/ChangeBlockBasePointV1-5.lsp @@ -0,0 +1,295 @@ +;;--------------------=={ Change Block Base Point }==-------------------;; +;; ;; +;; This program allows the user to change the base point for all ;; +;; block references of a block definition in a drawing. ;; +;; ;; +;; The program offers two commands: ;; +;; ;; +;; ------------------------------------------------------------------ ;; +;; CBP (Change Base Point) ;; +;; ------------------------------------------------------------------ ;; +;; ;; +;; This command will retain the insertion point coordinates for all ;; +;; references of the selected block. Hence visually, the block ;; +;; components will be moved around the insertion point when the ;; +;; base point is changed. ;; +;; ;; +;; ------------------------------------------------------------------ ;; +;; CBPR (Change Base Point Retain Reference Position) ;; +;; ------------------------------------------------------------------ ;; +;; ;; +;; This command will retain the position of the each block reference ;; +;; of the selected block. Hence, each block reference will be moved ;; +;; to retain the visual position when the base point is changed. ;; +;; ;; +;; ------------------------------------------------------------------ ;; +;; ;; +;; Upon issuing a command syntax at the AutoCAD command-line, the ;; +;; program will prompt the user to select a block for which to change ;; +;; the base point. ;; +;; ;; +;; Following a valid selection, the user is then prompted to specify ;; +;; a new base point relative to the selected block. ;; +;; ;; +;; The block definition (and block reference depending on the command ;; +;; used) will then be modified to reflect the new block base point. ;; +;; ;; +;; If the selected block is attributed, an ATTSYNC operation will ;; +;; also be performed to ensure all attributes are in the correct ;; +;; positions relative to the new base point. ;; +;; ;; +;; Finally, the active viewport is regenerated to reflect the changes ;; +;; throughout all references of the block. ;; +;; ;; +;; The program will furthermore perform successfully with rotated & ;; +;; scaled block references, constructed in any UCS plane. ;; +;; ;; +;; ------------------------------------------------------------------ ;; +;; Please Note: ;; +;; ------------------------------------------------------------------ ;; +;; ;; +;; A REGEN is required if the UNDO command is used to undo the ;; +;; operations performed by this program. ;; +;; ;; +;;----------------------------------------------------------------------;; +;; Author: Lee Mac, Copyright © 2013 - www.lee-mac.com ;; +;;----------------------------------------------------------------------;; +;; Version 1.5 - 20-10-2013 ;; +;;----------------------------------------------------------------------;; + +;; Retains Insertion Point Coordinates +(defun c:cbp nil (LM:changeblockbasepoint nil)) + +;; Retains Block Reference Position +(defun c:cbpr nil (LM:changeblockbasepoint t)) + +;;----------------------------------------------------------------------;; + +(defun LM:changeblockbasepoint ( flg / *error* bln cmd ent lck mat nbp vec ) + + (defun *error* ( msg ) + (foreach lay lck (vla-put-lock lay :vlax-true)) + (if (= 'int (type cmd)) (setvar 'cmdecho cmd)) + (LM:endundo (LM:acdoc)) + (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) + (princ (strcat "\nError: " msg)) + ) + (princ) + ) + + (while + (progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect Block: "))) + (cond + ( (= 7 (getvar 'errno)) + (princ "\nMissed, try again.") + ) + ( (= 'ename (type ent)) + (if (/= "INSERT" (cdr (assoc 0 (entget ent)))) + (princ "\nSelected object is not a block.") + ) + ) + ) + ) + ) + (if (and (= 'ename (type ent)) (setq nbp (getpoint "\nSpecify New Base Point: "))) + (progn + (setq mat (car (revrefgeom ent)) + vec (mxv mat (mapcar '- (trans nbp 1 0) (trans (cdr (assoc 10 (entget ent))) ent 0))) + bln (LM:blockname (vlax-ename->vla-object ent)) + ) + (LM:startundo (LM:acdoc)) + (vlax-for lay (vla-get-layers (LM:acdoc)) + (if (= :vlax-true (vla-get-lock lay)) + (progn + (vla-put-lock lay :vlax-false) + (setq lck (cons lay lck)) + ) + ) + ) + (vlax-for obj (vla-item (vla-get-blocks (LM:acdoc)) bln) + (vlax-invoke obj 'move vec '(0.0 0.0 0.0)) + ) + (if flg + (vlax-for blk (vla-get-blocks (LM:acdoc)) + (if (= :vlax-false (vla-get-isxref blk)) + (vlax-for obj blk + (if + (and + (= "AcDbBlockReference" (vla-get-objectname obj)) + (= bln (LM:blockname obj)) + (vlax-write-enabled-p obj) + ) + (vlax-invoke obj 'move '(0.0 0.0 0.0) (mxv (car (refgeom (vlax-vla-object->ename obj))) vec)) + ) + ) + ) + ) + ) + (if (= 1 (cdr (assoc 66 (entget ent)))) + (progn + (setq cmd (getvar 'cmdecho)) + (setvar 'cmdecho 0) + (vl-cmdf "_.attsync" "_N" bln) + (setvar 'cmdecho cmd) + ) + ) + (foreach lay lck (vla-put-lock lay :vlax-true)) + (vla-regen (LM:acdoc) acallviewports) + (LM:endundo (LM:acdoc)) + ) + ) + (princ) +) + +;; RefGeom (gile) +;; Returns a list whose first item is a 3x3 transformation matrix and +;; second item the object insertion point in its parent (xref, block or space) + +(defun refgeom ( ent / ang enx mat ocs ) + (setq enx (entget ent) + ang (cdr (assoc 050 enx)) + ocs (cdr (assoc 210 enx)) + ) + (list + (setq mat + (mxm + (mapcar '(lambda ( v ) (trans v 0 ocs t)) + '( + (1.0 0.0 0.0) + (0.0 1.0 0.0) + (0.0 0.0 1.0) + ) + ) + (mxm + (list + (list (cos ang) (- (sin ang)) 0.0) + (list (sin ang) (cos ang) 0.0) + '(0.0 0.0 1.0) + ) + (list + (list (cdr (assoc 41 enx)) 0.0 0.0) + (list 0.0 (cdr (assoc 42 enx)) 0.0) + (list 0.0 0.0 (cdr (assoc 43 enx))) + ) + ) + ) + ) + (mapcar '- (trans (cdr (assoc 10 enx)) ocs 0) + (mxv mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))) + ) + ) +) + +;; RevRefGeom (gile) +;; The inverse of RefGeom + +(defun revrefgeom ( ent / ang enx mat ocs ) + (setq enx (entget ent) + ang (cdr (assoc 050 enx)) + ocs (cdr (assoc 210 enx)) + ) + (list + (setq mat + (mxm + (list + (list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0) + (list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0) + (list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx)))) + ) + (mxm + (list + (list (cos ang) (sin ang) 0.0) + (list (- (sin ang)) (cos ang) 0.0) + '(0.0 0.0 1.0) + ) + (mapcar '(lambda ( v ) (trans v ocs 0 t)) + '( + (1.0 0.0 0.0) + (0.0 1.0 0.0) + (0.0 0.0 1.0) + ) + ) + ) + ) + ) + (mapcar '- (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx))))) + (mxv mat (trans (cdr (assoc 10 enx)) ocs 0)) + ) + ) +) + +;; Matrix x Vector - Vladimir Nesterovsky +;; Args: m - nxn matrix, v - vector in R^n + +(defun mxv ( m v ) + (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m) +) + +;; Matrix x Matrix - Vladimir Nesterovsky +;; Args: m,n - nxn matrices + +(defun mxm ( m n ) + ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n)) +) + +;; Matrix Transpose - Doug Wilson +;; Args: m - nxn matrix + +(defun trp ( m ) + (apply 'mapcar (cons 'list m)) +) + +;; Block Name - Lee Mac +;; Returns the true (effective) name of a supplied block reference + +(defun LM:blockname ( obj ) + (if (vlax-property-available-p obj 'effectivename) + (defun LM:blockname ( obj ) (vla-get-effectivename obj)) + (defun LM:blockname ( obj ) (vla-get-name obj)) + ) + (LM:blockname obj) +) + +;; Start Undo - Lee Mac +;; Opens an Undo Group. + +(defun LM:startundo ( doc ) + (LM:endundo doc) + (vla-startundomark doc) +) + +;; End Undo - Lee Mac +;; Closes an Undo Group. + +(defun LM:endundo ( doc ) + (while (= 8 (logand 8 (getvar 'undoctl))) + (vla-endundomark doc) + ) +) + +;; Active Document - Lee Mac +;; Returns the VLA Active Document Object + +(defun LM:acdoc nil + (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object)))) + (LM:acdoc) +) + +;;----------------------------------------------------------------------;; + +(vl-load-com) +(princ + (strcat + "\n:: ChangeBlockBasePoint.lsp | Version 1.5 | \\U+00A9 Lee Mac " + (menucmd "m=$(edtime,0,yyyy)") + " www.lee-mac.com ::" + "\n:: Available Commands:" + "\n:: \"CBP\" - Retain Insertion Point Position" + "\n:: \"CBPR\" - Retain Block Reference Position" + ) +) +(princ) + +;;----------------------------------------------------------------------;; +;; End of File ;; +;;----------------------------------------------------------------------;; \ No newline at end of file diff --git a/downloaded/Ellipse2pline.lsp b/downloaded/Ellipse2pline.lsp new file mode 100644 index 0000000..99dcb95 --- /dev/null +++ b/downloaded/Ellipse2pline.lsp @@ -0,0 +1,70 @@ +; Ellipse or ellipse arc to polyline +; Written By: Peter Jamtgaard 8/1/2006 +; Modified by Tom Beauford to convert Lines, Arcs, Splines, and Circles as well. +; Menu item: ^P(or C:El2p (load "El2p.lsp"));El2p +(defun C:El2p (/ El2p ss count) +(defun El2p (ent / sngIncrement sngPosition pedacept) + (setq obj (vlax-ename->vla-object ent) + EnTyp (cdr (assoc 0 (entget ent))) + ) + (princ "\nEntity Type = ")(princ EnTyp) + (cond + ((= EnTyp "ELLIPSE") + (setq obj (vlax-ename->vla-object ent) + sngIncrement (/ (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)) 100.0) + sngPosition 0.0 + ) + (command "ortho" "off" "pline") + (repeat 101 + (command (vlax-curve-getpointatdist obj sngPosition)) + (setq sngPosition (+ sngPosition sngIncrement)) + ) + (command "") + ); EnTyp = ELLIPSE + ((= EnTyp "CIRCLE") + (setq obj (vlax-ename->vla-object ent) + ps (vlax-variant-value (vlax-get-property obj 'Center)); Center + center (vlax-safearray->list ps) ; Center + radius (vlax-get-property obj 'Radius) ; Radius + pt1 (polar center 0 radius) ; start point for polyline + pt2 (polar center 3.14159 radius) ; second point for pline arc + ELA (vlax-get-property obj 'Layer) ; layer + ELT (vlax-get-property obj 'Linetype) ; Linetype + ELS (vlax-get-property obj 'LinetypeScale) ; LinetypeScale + PltSty (vlax-get-property obj 'PlotStyleName) ; PlotStyleName + TruClr (vlax-get-property obj 'TrueColor) ; TrueColor + ) + (command "pline" pt1 "Arc" "CE" center pt2 "Close") + (setq ent (entlast) + obj (vlax-ename->vla-object ent) + ) + (vlax-dump-object EOBJ) ; List object properties + (vl-catch-all-apply 'vla-put-Layer (list EOBJ ELA)) + (vl-catch-all-apply 'vla-put-Linetype (list EOBJ ELT)) + (vl-catch-all-apply 'vla-put-LinetypeScale (list EOBJ ELS)) + (vl-catch-all-apply 'vla-put-PlotStyleName (list EOBJ PltSty)) + (vl-catch-all-apply 'vla-put-TrueColor (list EOBJ TruClr)) + ); EnTyp = CIRCLE + + ((or(= EnTyp "ARC")(= EnTyp "LINE")) + (setq pedacept (Getvar "peditaccept")) + (setvar "peditaccept" 1) + (command "_.pedit" ent "_exit") + (setvar "peditaccept" pedacept) + ); EnTyp = ARC or LINE + (T(princ "\nEntity Type = ")(princ EnTyp)) + ); if (= (type ent) 'ENAME) +; (vla-delete objEllipse) + (princ) +) +(princ "\nSelect Lines, Arcs, Splines, Circles, Ellipses, and Ellipse Arcs: ") + (setq count 0) + (if (setq ss (ssget '((0 . "line,arc,spline,circle,ellipse")))) + (repeat (sslength ss) + (el2p (ssname ss count)) + (setq count (1+ count)) + ) + (princ "\nNo modifyable objects selected!") + ) + (princ) +); defun C:El2p \ No newline at end of file diff --git a/downloaded/HatchMaker.lsp b/downloaded/HatchMaker.lsp new file mode 100644 index 0000000..211e8ea --- /dev/null +++ b/downloaded/HatchMaker.lsp @@ -0,0 +1,364 @@ +;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp Hatch Maker (c) 2005 Larry Schiele + +;;;* ====== B E G I N C O D E N O W ====== +;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation +;;;* Lanny.Schiele@tmisystems.com +;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up. + +(defun C:DrawHatch (/) + (command "undo" "be") + (setq os (getvar "OSMODE")) + (setvar "OSMODE" 0) + (command "UCS" "w") + (command "PLINE" "0,0" "0,1" "1,1" "1,0" "c") + (command "zoom" "c" "0.5,0.5" 1.1) + (setvar "OSMODE" os) + (setvar "SNAPMODE" 1) + (setvar "SNAPUNIT" (list 0.01 0.01)) + (command "undo" "e") + (alert + "Draw pattern within 1x1 box using LINE or POINT entities only..." + ) + (princ) +) + +(defun C:SaveHatch (/ round dxf ListToFile + user SelSet SelSetSize ssNth + Ent EntInfo EntType pt1 pt2 + Dist AngTo AngFrom XDir YDir + Gap DeltaX DeltaY AngZone Counter + Ratio Factor HatchName HatchDescr + FileLines FileLines FileName + Scaler ScaledX ScaledY RF x + y h _AB _BC _AC + _AD _DE _EF _EH _FH + DimZin + ) +;;;* BEGIN NESTED FUNCTIONS + + (defun round (num) + (if (>= (- num (fix num)) 0.5) + (fix (1+ num)) + (fix num) + ) + ) + + (defun dxf (code EnameOrElist / VarType) + (setq VarType (type EnameOrElist)) + (if (= VarType (read "ENAME")) + (cdr (assoc code (entget EnameOrElist))) + (cdr (assoc code EnameOrElist)) + ) + ) + + + (defun ListToFile (TextList FileName DoOpenWithNotepad + AsAppend / TextItem + File RetVal + ) + (if (setq File (open FileName + (if AsAppend + "a" + "w" + ) + ) + ) + (progn + (foreach TextItem TextList + (write-line TextItem File) + ) + (setq File (close File)) + (if DoOpenWithNotepad + (startapp "notepad" FileName) + ) + ) + ) + (FindFile FileName) + ) + +;;;* END NESTED FUNCTIONS + + (princ + (strcat + "\n." + "\n 0,1 ----------- 1,1" + "\n | | " + "\n | Lines and | " + "\n | points must | " + "\n | be snapped | " + "\n | to nearest | " + "\n | 0.01 | " + "\n | | " + "\n 0,0 ----------- 1,0" + "\n." + "\nNote: Lines must be drawn within 0,0 to 1,1 and lie on a 0.01 grid." + ) + ) + (textscr) + (getstring "\nHit [ENTER] to continue...") + + (princ + "\nSelect 1x1 pattern of lines and/or points for new hatch pattern..." + ) + (while (not (setq SelSet (ssget (list (cons 0 "LINE,POINT"))))) + ) + (setq ssNth 0 + SelSetSize (sslength SelSet) + DimZin (getvar "DIMZIN") + ) + (setvar "DIMZIN" 11) + (if (> SelSetSize 0) + (princ "\nAnalyaing entities...") + ) + (while (< ssNth SelSetSize) + (setq Ent (ssname SelSet ssNth) + EntInfo (entget Ent) + EntType (dxf 0 EntInfo) + ssNth (+ ssNth 1) + ) + (cond + ((= EntType "POINT") + (setq pt1 (dxf 10 EntInfo) + FileLine (strcat "0," + (rtos (car pt1) 2 6) + "," + (rtos (cadr pt1) 2 6) + ",0,1,0,-1" + ) + ) + (princ (strcat "\n" FileLine)) + (setq FileLines (cons FileLine FileLines)) + ) + ((= EntType "LINE") + (setq pt1 (dxf 10 EntInfo) + pt2 (dxf 11 EntInfo) + Dist (distance pt1 pt2) + AngTo (angle pt1 pt2) + AngFrom (angle pt2 pt1) + IsValid nil + ) + (if + (or (equal (car pt1) (car pt2) 0.0001) + (equal (cadr pt1) (cadr pt2) 0.0001) + ) + (setq DeltaX 0 + DeltaY 1 + Gap (- Dist 1) + IsValid T + ) + (progn + (setq Ang (if (< AngTo pi) + AngTo + AngFrom + ) + AngZone (fix (/ Ang (/ pi 4))) + XDir (abs (- (car pt2) (car pt1))) + YDir (abs (- (cadr pt2) (cadr pt1))) + Factor 1 + RF 1 + ) + (cond + ((= AngZone 0) + (setq DeltaY (abs (sin Ang)) + DeltaX (abs (- (abs (/ 1.0 (sin Ang))) (abs (cos Ang))) + ) + ) + ) + ((= AngZone 1) + (setq DeltaY (abs (cos Ang)) + DeltaX (abs (sin Ang)) + ) + ) + ((= AngZone 2) + (setq DeltaY (abs (cos Ang)) + DeltaX (abs (- (abs (/ 1.0 (cos Ang))) (abs (sin Ang))) + ) + ) + ) + ((= AngZone 3) + (setq DeltaY (abs (sin Ang)) + DeltaX (abs (cos Ang)) + ) + ) + ) + (if (not (equal XDir YDir 0.001)) + (progn + (setq Ratio (if (< XDir YDir) + (/ YDir XDir) + (/ XDir YDir) + ) + RF (* Ratio Factor) + Scaler (/ 1 + (if (< XDir YDir) + XDir + YDir + ) + ) + ) + (if (not (equal Ratio (round Ratio) 0.001)) + (progn + (while + (and + (<= Factor 100) + (not (equal RF (round RF) 0.001)) + ) + (setq Factor (+ Factor 1) + RF (* Ratio Factor) + ) + ) + (if (and (> Factor 1) (<= Factor 100)) + (progn + (setq _AB (* XDir Scaler Factor) + _BC (* YDir Scaler Factor) + _AC (sqrt (+ (* _AB _AB) (* _BC _BC))) + _EF 1 + x 1 + ) + (while (< x (- _AB 0.5)) + (setq y (* x (/ YDir XDir)) + h (if (< Ang (/ pi 2)) + (- (+ 1 (fix y)) y) + (- y (fix y)) + ) + ) + (if (< h _EF) + (setq _AD x + _DE y + _AE (sqrt (+ (* x x) (* y y))) + _EF h + ) + ) + (setq x (+ x 1)) + ) + (if (< _EF 1) + (setq _EH (/ (* _BC _EF) _AC) + _FH (/ (* _AB _EF) _AC) + DeltaX (+ _AE + (if (> Ang (/ pi 2)) + (- _EH) + _EH + ) + ) + DeltaY (+ _FH) + Gap (- Dist _AC) + IsValid T + ) + ) + ) + ) + ) + ) + ) + ) + (if (= Factor 1) + (setq Gap (- Dist (abs (* Factor (/ 1 DeltaY)))) + IsValid T + ) + ) + ) + ) + (if + IsValid + (progn + (setq FileLine + (strcat + (angtos AngTo 0 6) + "," + (rtos (car pt1) 2 8) + "," + (rtos (cadr pt1) 2 8) + "," + (rtos DeltaX 2 8) + "," + (rtos DeltaY 2 8) + "," + (rtos Dist 2 8) + "," + (rtos Gap 2 8) + ) + ) + (princ (strcat "\n" FileLine)) + (setq FileLines (cons FileLine FileLines)) + ) + (princ (strcat "\n * * * Line with invalid angle " + (angtos AngTo 0 6) + (chr 186) + " omitted. * * *" + ) + ) + ) + ) + ((princ + (strcat "\n * * * Invalid entity " EntType " omitted.") + ) + ) + ) + ) + (setvar "DIMZIN" DimZin) + (if + (and + FileLines + (setq HatchDescr + (getstring T + "\nBriefly describe this hatch pattern: " + ) + ) + (setq FileName (getfiled "Hatch Pattern File" + "I:\\Acad\\Hatch\\" + "pat" + 1 + ) + ) + ) + (progn + (if (= HatchDescr "") + (setq HatchDescr "Custom hatch pattern") + ) + (setq HatchName (vl-filename-base FileName) + FileLines (cons (strcat "*" HatchName "," HatchDescr) + (reverse FileLines) + ) + ) + (princ + "\n============================================================" + ) + (princ + (strcat "\nPlease wait while the hatch file is created...\n" + ) + ) + (ListToFile FileLines FileName nil nil) + (command "delay" 1500) ;delay required so file can be created and found (silly, but req.) + (if (findfile FileName) + (progn + (setvar "HPNAME" HatchName) + (princ (strcat "\nHatch pattern '" + HatchName + "' is ready to use!" + ) + ) + ) + (progn + (princ "\nUnable to create hatch pattern file:") + (princ (strcat "\n " FileName)) + ) + ) + ) + (princ + (if FileLines + "\nCancelled." + "\nUnable to create hatch pattern from selected entities." + ) + ) + ) + (princ) +) + +(princ "\n ************************************************************** ") +(princ "\n** **") +(princ "\n* HatchMaker.lsp written by Lanny Schiele -- enjoy! *") +(princ "\n* *") +(princ "\n* Type in DRAWHATCH to have the environment created to draw. *") +(princ "\n* Type in SAVEHATCH to save the pattern you created. *") +(princ "\n** **") +(princ "\n ************************************************************** ") +(princ) diff --git a/downloaded/HatchMaker2.lsp b/downloaded/HatchMaker2.lsp new file mode 100644 index 0000000..fcfe61c --- /dev/null +++ b/downloaded/HatchMaker2.lsp @@ -0,0 +1,364 @@ +;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp Hatch Maker (c) 2005 Larry Schiele + +;;;* ====== B E G I N C O D E N O W ====== +;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation +;;;* Lanny.Schiele@tmisystems.com +;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up. + +(defun C:DrawHatch (/) + (command "undo" "be") + (setq os (getvar "OSMODE")) + (setvar "OSMODE" 0) + (command "UCS" "w") + (command "PLINE" "0,0" "0,1" "1,1" "1,0" "c") + (command "zoom" "c" "0.5,0.5" 1.1) + (setvar "OSMODE" os) + (setvar "SNAPMODE" 1) + (setvar "SNAPUNIT" (list 0.01 0.01)) + (command "undo" "e") + (alert + "Draw pattern within 1x1 box using LINE or POINT entities only..." + ) + (princ) +) + +(defun C:SaveHatch (/ round dxf ListToFile + user SelSet SelSetSize ssNth + Ent EntInfo EntType pt1 pt2 + Dist AngTo AngFrom XDir YDir + Gap DeltaX DeltaY AngZone Counter + Ratio Factor HatchName HatchDescr + FileLines FileLines FileName + Scaler ScaledX ScaledY RF x + y h _AB _BC _AC + _AD _DE _EF _EH _FH + DimZin + ) +;;;* BEGIN NESTED FUNCTIONS + + (defun round (num) + (if (>= (- num (fix num)) 0.5) + (fix (1+ num)) + (fix num) + ) + ) + + (defun dxf (code EnameOrElist / VarType) + (setq VarType (type EnameOrElist)) + (if (= VarType (read "ENAME")) + (cdr (assoc code (entget EnameOrElist))) + (cdr (assoc code EnameOrElist)) + ) + ) + + + (defun ListToFile (TextList FileName DoOpenWithNotepad + AsAppend / TextItem + File RetVal + ) + (if (setq File (open FileName + (if AsAppend + "a" + "w" + ) + ) + ) + (progn + (foreach TextItem TextList + (write-line TextItem File) + ) + (setq File (close File)) + (if DoOpenWithNotepad + (startapp "notepad" FileName) + ) + ) + ) + (FindFile FileName) + ) + +;;;* END NESTED FUNCTIONS + + (princ + (strcat + "\n." + "\n 0,1 ----------- 1,1" + "\n | | " + "\n | Lines and | " + "\n | points must | " + "\n | be snapped | " + "\n | to nearest | " + "\n | 0.01 | " + "\n | | " + "\n 0,0 ----------- 1,0" + "\n." + "\nNote: Lines must be drawn within 0,0 to 1,1 and lie on a 0.01 grid." + ) + ) + (textscr) + (getstring "\nHit [ENTER] to continue...") + + (princ + "\nSelect 1x1 pattern of lines and/or points for new hatch pattern..." + ) + (while (not (setq SelSet (ssget (list (cons 0 "LINE,POINT"))))) + ) + (setq ssNth 0 + SelSetSize (sslength SelSet) + DimZin (getvar "DIMZIN") + ) + (setvar "DIMZIN" 11) + (if (> SelSetSize 0) + (princ "\nAnalyaing entities...") + ) + (while (< ssNth SelSetSize) + (setq Ent (ssname SelSet ssNth) + EntInfo (entget Ent) + EntType (dxf 0 EntInfo) + ssNth (+ ssNth 1) + ) + (cond + ((= EntType "POINT") + (setq pt1 (dxf 10 EntInfo) + FileLine (strcat "0," + (rtos (car pt1) 2 6) + "," + (rtos (cadr pt1) 2 6) + ",0,1,0,-1" + ) + ) + (princ (strcat "\n" FileLine)) + (setq FileLines (cons FileLine FileLines)) + ) + ((= EntType "LINE") + (setq pt1 (dxf 10 EntInfo) + pt2 (dxf 11 EntInfo) + Dist (distance pt1 pt2) + AngTo (angle pt1 pt2) + AngFrom (angle pt2 pt1) + IsValid nil + ) + (if + (or (equal (car pt1) (car pt2) 0.00000000001) + (equal (cadr pt1) (cadr pt2) 0.00000000001) + ) + (setq DeltaX 0 + DeltaY 1 + Gap (- Dist 1) + IsValid T + ) + (progn + (setq Ang (if (< AngTo pi) + AngTo + AngFrom + ) + AngZone (fix (/ Ang (/ pi 4))) + XDir (abs (- (car pt2) (car pt1))) + YDir (abs (- (cadr pt2) (cadr pt1))) + Factor 1 + RF 1 + ) + (cond + ((= AngZone 0) + (setq DeltaY (abs (sin Ang)) + DeltaX (abs (- (abs (/ 1.0 (sin Ang))) (abs (cos Ang))) + ) + ) + ) + ((= AngZone 1) + (setq DeltaY (abs (cos Ang)) + DeltaX (abs (sin Ang)) + ) + ) + ((= AngZone 2) + (setq DeltaY (abs (cos Ang)) + DeltaX (abs (- (abs (/ 1.0 (cos Ang))) (abs (sin Ang))) + ) + ) + ) + ((= AngZone 3) + (setq DeltaY (abs (sin Ang)) + DeltaX (abs (cos Ang)) + ) + ) + ) + (if (not (equal XDir YDir 0.001)) + (progn + (setq Ratio (if (< XDir YDir) + (/ YDir XDir) + (/ XDir YDir) + ) + RF (* Ratio Factor) + Scaler (/ 1 + (if (< XDir YDir) + XDir + YDir + ) + ) + ) + (if (not (equal Ratio (round Ratio) 0.001)) + (progn + (while + (and + (<= Factor 100) + (not (equal RF (round RF) 0.001)) + ) + (setq Factor (+ Factor 1) + RF (* Ratio Factor) + ) + ) + (if (and (> Factor 1) (<= Factor 100)) + (progn + (setq _AB (* XDir Scaler Factor) + _BC (* YDir Scaler Factor) + _AC (sqrt (+ (* _AB _AB) (* _BC _BC))) + _EF 1 + x 1 + ) + (while (< x (- _AB 0.5)) + (setq y (* x (/ YDir XDir)) + h (if (< Ang (/ pi 2)) + (- (+ 1 (fix y)) y) + (- y (fix y)) + ) + ) + (if (< h _EF) + (setq _AD x + _DE y + _AE (sqrt (+ (* x x) (* y y))) + _EF h + ) + ) + (setq x (+ x 1)) + ) + (if (< _EF 1) + (setq _EH (/ (* _BC _EF) _AC) + _FH (/ (* _AB _EF) _AC) + DeltaX (+ _AE + (if (> Ang (/ pi 2)) + (- _EH) + _EH + ) + ) + DeltaY (+ _FH) + Gap (- Dist _AC) + IsValid T + ) + ) + ) + ) + ) + ) + ) + ) + (if (= Factor 1) + (setq Gap (- Dist (abs (* Factor (/ 1 DeltaY)))) + IsValid T + ) + ) + ) + ) + (if + IsValid + (progn + (setq FileLine + (strcat + (angtos AngTo 0 6) + "," + (rtos (car pt1) 2 8) + "," + (rtos (cadr pt1) 2 8) + "," + (rtos DeltaX 2 8) + "," + (rtos DeltaY 2 8) + "," + (rtos Dist 2 8) + "," + (rtos Gap 2 8) + ) + ) + (princ (strcat "\n" FileLine)) + (setq FileLines (cons FileLine FileLines)) + ) + (princ (strcat "\n * * * Line with invalid angle " + (angtos AngTo 0 6) + (chr 186) + " omitted. * * *" + ) + ) + ) + ) + ((princ + (strcat "\n * * * Invalid entity " EntType " omitted.") + ) + ) + ) + ) + (setvar "DIMZIN" DimZin) + (if + (and + FileLines + (setq HatchDescr + (getstring T + "\nBriefly describe this hatch pattern: " + ) + ) + (setq FileName (getfiled "Hatch Pattern File" + "I:\\Acad\\Hatch\\" + "pat" + 1 + ) + ) + ) + (progn + (if (= HatchDescr "") + (setq HatchDescr "Custom hatch pattern") + ) + (setq HatchName (vl-filename-base FileName) + FileLines (cons (strcat "*" HatchName "," HatchDescr) + (reverse FileLines) + ) + ) + (princ + "\n============================================================" + ) + (princ + (strcat "\nPlease wait while the hatch file is created...\n" + ) + ) + (ListToFile FileLines FileName nil nil) + (command "delay" 1500) ;delay required so file can be created and found (silly, but req.) + (if (findfile FileName) + (progn + (setvar "HPNAME" HatchName) + (princ (strcat "\nHatch pattern '" + HatchName + "' is ready to use!" + ) + ) + ) + (progn + (princ "\nUnable to create hatch pattern file:") + (princ (strcat "\n " FileName)) + ) + ) + ) + (princ + (if FileLines + "\nCancelled." + "\nUnable to create hatch pattern from selected entities." + ) + ) + ) + (princ) +) + +(princ "\n ************************************************************** ") +(princ "\n** **") +(princ "\n* HatchMaker.lsp written by Lanny Schiele -- enjoy! *") +(princ "\n* *") +(princ "\n* Type in DRAWHATCH to have the environment created to draw. *") +(princ "\n* Type in SAVEHATCH to save the pattern you created. *") +(princ "\n** **") +(princ "\n ************************************************************** ") +(princ) diff --git a/downloaded/MLLA.lsp b/downloaded/MLLA.lsp new file mode 100644 index 0000000..874a2f5 --- /dev/null +++ b/downloaded/MLLA.lsp @@ -0,0 +1,36 @@ +(DEFUN C:MLLA ( / ) + (prompt "/nSelect multileaders: ") + (if (setq ss (ssget ":L" '((0 . "MULTILEADER")))); IF anything is found when to makes a selection of mleaders + (progn ; THEN + (setq mlent (entsel "/nSelect multileader to align to: "); prompt user to select mleader to align others to + ed (entget (car mlent)); store entity data for selected mleader + txxpt(cadr(assoc 12 ed)); store x point for text insertion + dlxpt(cadr (assoc 10 (member '(302 . "LEADER{") ed))); store x point for dogleg object + entqty (sslength ss); store quantity of mleaders selected + cnt 0); set counter to 0 + (while (< cnt entqty); while there are still mleaders in list + (setq mlent (ssname ss cnt); store entity name (starting with the first mleader) + ed (entget mlent); store entity definition + + old_txxpt (assoc 12 ed); store entities text object point data + new_txxpt (cons txxpt (cddr old_txxpt)); create new text object point data utilizing x point from mleader to align to + ed (subst (cons 12 new_txxpt) old_txxpt ed); swap old text object point data for new in entity record + + old_tfxpt (assoc 10 ed); store entities text frame object point data + x-diff (- (- (cadr old_txxpt) txxpt)); find delta-x between current ent and selected alignment mleader + newx (+ x-diff (cadr old_tfxpt)); create new x point coordinate for text frame object + new_tfxpt (cons newx (cddr old_tfxpt)); create new text object point data utilizing newly created x point + ed (subst (cons 10 new_tfxpt) old_tfxpt ed); swap old text frame object point data for new in entity record + + old_dlxpt (assoc 10 (member '(302 . "LEADER{") ed)); store entities dogleg object point data + new_dlxpt (cons dlxpt (cddr old_dlxpt)); create new dogleg object point data utilizing x point from mleader to align to + ed (subst (cons 10 new_dlxpt) old_dlxpt ed)); swap old dogleg object point data for new in entity record + (entmod ed); write new data to database + + (setq cnt (1+ cnt)); set counter to advance to the next entity in selection set + ); end WHILE + ); end THEN + ); end IF (no ELSE statement specified) + (princ); exit quietly + ) +(princ); load clean diff --git a/downloaded/PLDiet.lsp b/downloaded/PLDiet.lsp new file mode 100644 index 0000000..ea95b83 --- /dev/null +++ b/downloaded/PLDiet.lsp @@ -0,0 +1,221 @@ +;;; PLDIET.lsp [command name: PLD] +;;; To put lightweight PolyLines on a DIET (remove excess vertices); usually +;;; used for contours with too many too-closely-spaced vertices. +;;; Concept from PVD routine [posted on AutoCAD Customization Discussion +;;; Group by oompa_l, July 2009] by Brian Hailey, added to by CAB, and +;;; WEED and WEED2 routines by Skyler Mills at Cadalyst CAD Tips [older +;;; routines for "heavy" Polylines that won't work on newer lightweight ones]; +;;; simplified in entity data list processing, and enhanced in other ways [error +;;; handling, default values, join collinear segments beyond max. distance, +;;; limit to current space/tab, account for change in direction across 0 degrees, +;;; option to keep or eliminate arc segments] by Kent Cooper, August 2009. +;;; Last edited 28 August 2013 +; +(defun C:PLD + (/ *error* cmde disttemp cidtemp arctemp plinc plsel pl + pldata ucschanged front 10to42 vinc verts vert1 vert2 vert3) +; + (defun *error* (errmsg) + (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break")) + (princ (strcat "\nError: " errmsg)) + ); end if + (if ucschanged (command "_.ucs" "_prev")) + ; ^ i.e. don't go back unless routine reached UCS change but didn't change back + (command "_.undo" "_end") + (setvar 'cmdecho cmde) + ); end defun - *error* +; + (setq cmde (getvar 'cmdecho)) + (setvar 'cmdecho 0) + (command "_.undo" "_begin") + (setq + disttemp + (getdist + (strcat + "\nMaximum distance between non-collinear vertices to straighten" + (if *distmax* (strcat " <" (rtos *distmax* 2 2) ">") ""); default only if not first use + ": " + ); end strcat + ); end getdist & disttemp + *distmax* + (cond + (disttemp); user entered number or picked distance + (*distmax*); otherwise, user hit Enter - keep value + ); end cond & *distmax* + cidtemp + (getangle + (strcat + "\nMaximum change in direction to straighten" + (strcat ; offer prior choice if not first use; otherwise 15 degrees + " <" + (if *cidmax* (angtos *cidmax*) (angtos (/ pi 12))) + ">" + ); end strcat + ": " + ); end strcat + ); end getdist & cidtemp + *cidmax* + (cond + (cidtemp); user entered number or picked angle + (*cidmax*); Enter with prior value set - use that + ((/ pi 12)); otherwise [Enter on first use] - 15 degrees + ); end cond & *cidmax* + plinc 0 ; incrementer through selection set of Polylines + ); end setq + (initget "Retain Straighten") + (setq + arctemp + (getkword + (strcat + "\nRetain or Straighten arc segments [R/S] <" + (if *arcstr* (substr *arcstr* 1 1) "S"); at first use, S default; otherwise, prior choice + ">: " + ); end strcat + ); end getkword + *arcstr* + (cond + (arctemp); if User typed something, use it + (*arcstr*); if Enter and there's a prior choice, keep that + ("Straighten"); otherwise [Enter on first use], Straighten + ); end cond & *arcstr* + ); end setq +; + (prompt "\nSelect LWPolylines to put on a diet, or press Enter to select all: ") + (cond + ((setq plsel (ssget '((0 . "LWPOLYLINE"))))); user-selected Polylines + ((setq plsel (ssget "X" (list '(0 . "LWPOLYLINE") (cons 410 (getvar 'ctab)))))) + ; all Polylines [in current space/tab only] + ); end cond +; + (repeat (sslength plsel) + (setq pl (ssname plsel plinc)) + (while + (equal (vlax-curve-getStartPoint pl) (vlax-curve-getPointAtParam pl 1) 1e-6) + ; to correct for possibility that more than one vertices at beginning coincide, + ; in which case Pline does not define a CS under UCS OBject, causing error + (command "_.pedit" pl "_edit" "_straighten" "" "" "_go" "_exit" "") + ); while + (setq pldata (entget pl)) + (if (/= (cdr (last pldata)) (trans '(0 0 1) 1 0)); extr. direction not parallel current CS + ; for correct angle & distance calculations [projected onto current construction + ; plane], since 10-code entries for LWPolylines are only 2D points: + (progn + (command "_.ucs" "_new" "_object" pl) ; set UCS to match object + (setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't + ); end progn + ); end if + (setq + front ; list of "front end" [pre-vertices] entries, minus entity names & handle + (vl-remove-if + '(lambda (x) + (member (car x) '(-1 330 5 10 40 41 42 210)) + ); end lambda + pldata + ); end removal & front + 10to42 ; list of all code 10, 40, 41, 42 entries only + (vl-remove-if-not + '(lambda (x) + (member (car x) '(10 40 41 42)) + ); end lambda + pldata + ); end removal & 10to42 + vinc (/ (length 10to42) 4); incrementer for vertices within each Polyline + verts nil ; eliminate from previous Polyline [if any] + ); end setq + (if (= *arcstr* "Straighten") + (progn + (setq bulges ; find any bulge factors + (vl-remove-if-not + '(lambda (x) + (and + (= (car x) 42) + (/= (cdr x) 0.0) + ); end and + ); end lambda + 10to42 + ); end removal & bulges + ); end setq + (foreach x bulges (setq 10to42 (subst '(42 . 0.0) x 10to42))) + ; straighten all arc segments to line segments + ); end progn + ); end if + (repeat vinc + (setq + verts ; sub-group list: separate list of four entries for each vertex + (cons + (list + (nth (- (* vinc 4) 4) 10to42) + (nth (- (* vinc 4) 3) 10to42) + (nth (- (* vinc 4) 2) 10to42) + (nth (1- (* vinc 4)) 10to42) + ); end list + verts + ); end cons & verts + vinc (1- vinc) ; will be 0 at end + ); end setq + ); end repeat + (while (nth (+ vinc 2) verts); still at least 2 more vertices + (if + (or ; only possible if chose to Retain arc segments + (/= (cdr (assoc 42 (nth vinc verts))) 0.0); next segment is arc + (/= (cdr (assoc 42 (nth (1+ vinc) verts))) 0.0); following segment is arc + ); end or + (setq vinc (1+ vinc)); then - don't straighten from here; move to next + (progn ; else - analyze from current vertex + (setq + vert1 (cdar (nth vinc verts)) ; point-list location of current vertex + vert2 (cdar (nth (1+ vinc) verts)); of next one + vert3 (cdar (nth (+ vinc 2) verts)); of one after that + ang1 (angle vert1 vert2) + ang2 (angle vert2 vert3) + ); end setq + (if + (or + (equal ang1 ang2 0.0001); collinear, ignoring distance + (and + (<= (distance vert1 vert3) *distmax*) + ; straightens if direct distance from current vertex to two vertices later is + ; less than or equal to maximum; if preferred to compare distance along + ; Polyline through intermediate vertex, replace above line with this: + ; (<= (+ (distance vert1 vert2) (distance vert2 vert3)) *distmax*) + (<= + (if (> (abs (- ang1 ang2)) pi); if difference > 180 degrees + (+ (min ang1 ang2) (- (* pi 2) (max ang1 ang2))) + ; then - compensate for change in direction crossing 0 degrees + (abs (- ang1 ang2)); else - size of difference + ); end if + *cidmax* + ); end <= + ); end and + ); end or + (setq verts (vl-remove (nth (1+ vinc) verts) verts)) + ; then - remove next vertext, stay at current vertex for next comparison + (setq vinc (1+ vinc)); else - leave next vertex, move to it as new base + ); end if - distance & change in direction analysis + ); end progn - line segments + ); end if - arc segment check + ); end while - working through vertices + (setq + front (subst (cons 90 (length verts)) (assoc 90 front) front) + ; update quantity of vertices for front end + 10to42 nil ; clear original set + ); end setq + (foreach x verts (setq 10to42 (append 10to42 x))) + ; un-group four-list vertex sub-lists back to one list of all 10, 40, 41, 42 entries + (setq pldata (append front 10to42 (list (last pldata)))) + ; put front end, vertex entries and extrusion direction back together + (entmake pldata) + (entdel pl); remove original + (setq plinc (1+ plinc)); go on to next Polyline + (if ucschanged + (progn + (command "_.ucs" "_prev") + (setq ucschanged nil) ; eliminate UCS reset in *error* since routine did it already + ); end progn + ); end if - UCS reset + ); end repeat - stepping through set of Polylines + (command "_.undo" "_end") + (setvar 'cmdecho cmde) + (princ) +); end defun - PLD +(prompt "\nType PLD to put PolyLines on a Diet.") diff --git a/downloaded/Polyarea.lsp b/downloaded/Polyarea.lsp new file mode 100644 index 0000000..afeeb9e --- /dev/null +++ b/downloaded/Polyarea.lsp @@ -0,0 +1,35 @@ +;;POLYAREA.LSP +;; Adds the area of one or more closed polylines +;; +(defun C:POLYAREA (/ a ss n du) + (setq a 0 + du (getvar "dimunit") + ss (ssget '((0 . "*POLYLINE")))) + (if ss + (progn + (setq n (1- (sslength ss))) + (while (>= n 0) + (command "_.area" "_o" (ssname ss n)) + (setq a (+ a (getvar "area")) + n (1- n))) + (alert + (strcat "The total area of the selected\nobject(s) is " + (if (or (= du 3)(= du 4)(= du 6)) +; +;The following 2 lines translate the area to square inches and feet +;for users using US engineering or architectural units: +; + (strcat (rtos a 2 2) " square inches,\nor " + (rtos (/ a 144.0) 2 3) " square feet.") +; +;In the following line, change the word "units" to whatever units +;you are using - meters, millimeters, feet, etc. +; + (strcat (rtos (/ a 10000) 2 3) " square meters."))))) + (alert "\nNo Polylines selected!")) + (princ) +) +(alert + (strcat "POLYAREA.LSP" + "\n\n Type POLYAREA to start")) +(princ) diff --git a/downloaded/StripMtext v5-0c.lsp b/downloaded/StripMtext v5-0c.lsp new file mode 100644 index 0000000..9d2c194 --- /dev/null +++ b/downloaded/StripMtext v5-0c.lsp @@ -0,0 +1,1696 @@ +;;;; StripMtext Version 5.0c for AutoCAD 2000 and above +;;;; Removes embedded Mtext formatting +;;;; +;;;; Copyright© Steve Doman and Joe Burke 2010 +;;;; +;;;; The authors grant permission to use, copy, and modify this routine +;;;; for personal use only and for the use of other AutoCAD users within +;;;; your organization. Selling, modifying, or exchanging this software +;;;; for a fee, or incorporation within a commercial software product, is +;;;; expressly prohibited. All other rights are reserved by the authors. +;;;; +;;;; Please send comments, wish lists, or bug reports to: +;;;; cadabyss@gmail.com or lowercase@hawaii.rr.com +;;;; +;;;; Look for new stable releases at: +;;;; http://cadabyss.wordpress.com/ +;;;; +;;;; More information may also be found at: +;;;; http://www.theswamp.org/ +;;;; Subforum: "Show your stuff", Subject: "StripMtext v5" +;;;; +;;;; +;;;; DESCRIPTION +;;;; +;;;; This AutoLISP program creates a command "StripMtext" (shortcut +;;;; "SMT"), that will enable the user to quickly remove selected +;;;; formatting codes from selected Mtext, Mleaders, Dimensions, Tables, +;;;; and Multiline Attributes. +;;;; +;;;; StripMtext can remove the following types of formatting: +;;;; +;;;; Alignment +;;;; Background Masks +;;;; Color +;;;; Columns +;;;; Fields (converts fields to static text) +;;;; Font +;;;; Height +;;;; Line Feed (newline, line break, carriage return) +;;;; Non-breaking Space +;;;; Obliquing +;;;; Overline +;;;; Paragraph (embedded justification, line spacing, indents) +;;;; Stacking +;;;; Tabs +;;;; Tracking +;;;; Underline +;;;; Width +;;;; +;;;; +;;;; CAVEATS +;;;; +;;;; Acad Versions - +;;;; If your version of AutoCAD does not support a formatting code +;;;; introduced in a latter year, that format will be disabled and appear +;;;; grayed-out in the dialog. +;;;; +;;;; Locked Table Cells - +;;;; If locked cells are found in a table while processing, they will be +;;;; skipped and the message "Some table cells are locked" will be +;;;; printed at the commnand prompt. This is by design and intended to +;;;; protect cell contents from accidental stripping. +;;;; +;;;; Reformatting Alignment - +;;;; It has been observed that after running StripMtext to remove +;;;; alignment formats from dimension objects, AutoCAD will sometimes +;;;; automatically add back the alignment format ("\\A1;"). AutoCAD's +;;;; apparent reformatting behavior makes it appear that there is a bug +;;;; in this routine. However tests indicate that the dimension mtext +;;;; string was indeed stripped correctly but AutoCAD, for what ever +;;;; reason, put it back. A similar situation occurs with Multiline +;;;; Attributes. +;;;; +;;;; Reformatting Fonts - +;;;; AutoCAD will automatically add back font formatting around +;;;; certain symbols characters after stripping, e.g. Isocpeur font +;;;; is automatically reapplied to the centerline symbol. +;;;; +;;;; Dimension Fractions - +;;;; StripMtext does not unstack fractions that are a part of the displayed +;;;; measurement value, i.e. "<>". It will remove any formatting +;;;; applied before, to, and after the measurement value. +;;;; +;;;; Fields Updating - +;;;; StripMtext uses the UPDATEFIELD command prior to removing formatting +;;;; from Fields embedded in Mtext and Multiline Attributes. +;;;; +;;;; +;;;; HOW TO LOAD (for the newbie) +;;;; +;;;; There are a few different methods to load an AutoLISP program. +;;;; Perhaps the easiest method is to type APPLOAD at the command prompt. +;;;; Then browse to the location of this file. Highlight the file name, +;;;; and then hit "Load". Hit the "Close" button to dismiss the APPLOAD +;;;; dialog. This procedure loads the program into the current drawing. +;;;; +;;;; To automatically load this file each time you open a drawing, add +;;;; the filename to APPLOAD's Startup Suite: APPLOAD > Contents > Add > +;;;; Browse to file > Load. +;;;; +;;;; +;;;; HOW TO USE +;;;; +;;;; (1) When you first start StripMtext, you will be asked to select +;;;; objects. When you have finished selecting, hit ENTER. +;;;; +;;;; Alternatively, if you pre-select (grip) objects and then issue +;;;; the StripMtext command, the pre-selected objects will be +;;;; accepted and the routine will move on to the next step without +;;;; further prompting. This so called "noun/verb" selection +;;;; behavior is dependent on the system variable PICKFIRST being set +;;;; to 1. +;;;; +;;;; With either selection method you choose to use, StripMtext will +;;;; remove from your selection any unsupported objects and any +;;;; objects that reside on locked layers. +;;;; +;;;; (2) Next, a dialog window will appear that displays a list of the +;;;; names of each formatting code with a corresponding check box. +;;;; Turn on the check box for each type of formatting you wish to +;;;; remove. You can quickly turn on or off all check boxes by using +;;;; the "Select All" or "Clear All" buttons. +;;;; +;;;; (3) If you would like StripMtext to save your checked marked +;;;; settings as a your default, turn on the "Remember Settings" +;;;; check box. StripMtext will store your default settings in the +;;;; Windows Registry. +;;;; +;;;; (4) Hit the "Ok" button to proceed with removing formats or the +;;;; "Cancel" button to exit without making changes. +;;;; +;;;; (5) Enjoy! +;;;; +;;;; +;;;; You are encouraged to spend a few minutes experimenting with +;;;; different format removal settings using a temporary drawing. If for +;;;; any reason you do not like the results, you can immediately issue an +;;;; UNDO command to restore your drawing to its prior condition. +;;;; +;;;; +;;;; HOW TO USE BY SCRIPT OR AUTOLISP +;;;; +;;;; When the StripMtext file loads into the drawing, it purposely +;;;; exposes the StripMtext function for your use during scripts and/or +;;;; your own AutoLISP routines. +;;;; +;;;; This function by-passes the user interface and therefore is an +;;;; excellent method to remove formatting from a batch of drawings +;;;; without user input, or to use in your own custom commands where you +;;;; need to remove Mtext formatting. +;;;; +;;;; To do this, your script or AutoLISP routine must load the StripMtext +;;;; file into the current drawing and then call StripMtext with valid +;;;; arguments. +;;;; +;;;; Syntax: +;;;; +;;;; (StripMtext SS Formats) +;;;; +;;;; SS A pickset containing entities to process. StripMtext will +;;;; ignore entities in the pickset that it does not support. +;;;; +;;;; Supported entities +;;;; ------------------ +;;;; Dimensions +;;;; Mleaders +;;;; Mtext +;;;; Multiline Attributes (embedded in block inserts) +;;;; Tables +;;;; +;;;; Formats A string or a list of strings containing format "key code" +;;;; options. Each key code is mapped to a particular type of +;;;; format as listed below. A caret "^" preceding a format +;;;; code negates that format code, i.e. it explicitly means +;;;; not to remove that particular format. +;;;; +;;;; Available format key codes +;;;; -------------------------- +;;;; "A" = Alignment +;;;; "B" = taBs +;;;; "C" = Color +;;;; "D" = fielDs (converts fields to static text) +;;;; "F" = Font +;;;; "H" = Height +;;;; "L" = Linefeed (newline, line break, carriage return) +;;;; "M" = background Mask +;;;; "N" = columNs +;;;; "O" = Overline +;;;; "P" = Paragraph (embedded justification, line spacing, indents) +;;;; "Q" = obliQue +;;;; "S" = Stacking +;;;; "T" = Tracking +;;;; "U" = Underline +;;;; "W" = Width +;;;; "~" = non-breaking space +;;;; "*" = all formats +;;;; +;;;; +;;;; Example 1: +;;;; +;;;; Load the StripMText file from script or AutoLISP. Assumes +;;;; StripMtext file resides in an AutoCAD support file search folder: +;;;; +;;;; (load "StripMtext v5-0a") ;_ check and update file name +;;;; +;;;; +;;;; Example 2: +;;;; +;;;; Prompt the user to select objects and remove only color, font, & +;;;; height formatting. There will not be a dialog or any other prompt +;;;; for choosing formats. +;;;; +;;;; (if (setq ss (ssget)) (StripMtext ss "CFH")) +;;;; - OR - +;;;; (if (setq ss (ssget)) (StripMtext ss '("C" "F" "H"))) +;;;; +;;;; +;;;; Example 3: +;;;; +;;;; Remove all formatting except hard returns from all supported +;;;; entitites without a prompt: +;;;; +;;;; (StripMtext (ssget "x") "*^L") +;;;; - OR - +;;;; (StripMtext (ssget "x") '("*" "^L")) +;;;; +;;;; Caution: +;;;; +;;;; Never run the above function on a batch of drawings without a +;;;; thorough understanding of how the format removal options work and +;;;; how removing them affects the end results. Experiment to become +;;;; familiar with the options before using on a batch of drawings. +;;;; +;;;; +;;;; HISTORY +;;;; +;;;; v1.0 06-14-1999 "The DSAKO Years" R14 +;;;; A first attempt of dealing with the problem of removing Mtext +;;;; formatting came while writing a routine named "DSAKO" (short for +;;;; "Dimstyle Apply Keep Overrides"). It was discovered that Mtext +;;;; formatting was overriding the text style height and font. Wrote a +;;;; subfunction called ClearMtext which stripped font, height, and +;;;; stacked fraction formatting from Mtext. sd +;;;; +;;;; v2.0 08-25-2001 "First stand alone StripMtext version" +;;;; Faster speed and removes all current formatting possibilities, +;;;; except linefeeds. sd +;;;; +;;;; v3.0 05-26-2003 "The Uhden Unformat Version" Vlisp +;;;; Powered by the new Unformat parser function written by John Uhden, +;;;; which provided much better, faster, and more reliable format +;;;; removing than previous versions. Added support for dimensions +;;;; objects and introduced a new DCL allowing users to choose individual +;;;; formats and save defaults. sd +;;;; +;;;; v3.05 01-14-04 +;;;; "Quit/Exit" bug fixed. sd +;;;; +;;;; v3.06 03-21-04 +;;;; Only changes to comments, otherwise same as v3.05. sd +;;;; +;;;; v3.07 04-15-04 +;;;; Fixed a "Unknown dimension" bug when drawing contained 2LineAngular +;;;; dimensions. Thanks to Keith Kempker for reporting this error and for +;;;; helping with debugging. sd +;;;; +;;;; v3.08 03-22-06 +;;;; Per request from Paul Muti, exposed subfunctions such that +;;;; StripMtext may be run from a script or another lisp. sd +;;;; +;;;; v3.09 01-17-07 +;;;; Fixed "Error: bad argument value: positive 0" This bug was reported +;;;; by Joe Burke when the routine processes an mtext object which begins +;;;; with a return, example "\\Ptest". Joe also found the bug and +;;;; provided code to fix the problem! This version incorporates his +;;;; solution. Thanks Joe! sd +;;;; +;;;; v4.0 Beta - "The Lost Version" +;;;; This version was never released to the public due to programming +;;;; difficulties which I could not overcome. Since a few copies went +;;;; out for beta testing, I felt it necessary to include version 4 in +;;;; the history list so as to bump the next version up and avoid any +;;;; confusion with the so called lost version. sd +;;;; +;;;; +;;;; v5.0 01-01-10 "The Joe Burke RegExp Version" +;;;; The stripping functions in this version have been completely +;;;; rewritten by Joe Burke and make use of the search and replace power +;;;; of regular expressions via the RegExp object. Joe Burke's coding +;;;; added support to remove all current Mtext formatting codes including +;;;; new format codes for tabs, indents, embedded justification, fields, +;;;; columns, and background masks. Joe also added support for +;;;; processing new entity objects that contain mtext: Mleaders, Tables, +;;;; and Multiline Attributes. Other changes are the elimination of the +;;;; external DCL file by creating a temporary DCL written "on the fly". +;;;; Comments have been rewritten and expanded to make it easier for +;;;; new user to understand how to load and run. I also wish to thank +;;;; Lee Mac for creating animated GIFs demonstrating StripMtext in +;;;; action. sd +;;;; +;;;; v5.0a 02-01-10 +;;;; 1.) Changed handling of dimensions objects to preserve +;;;; associativity of measurement value. 2.) Fixed compatibility +;;;; issue when processing locked Table cells prior to AutoCAD 2008. +;;;; 3.) Fixed failure to remove columns when Textstyle is +;;;; annotative. 4.) Added work around for AutoCAD problem when +;;;; user issues an UNDO after stripping Fields. 5.) Improved +;;;; handling of stacked fractions to preserve readability. +;;;; Thanks to Ian Bryant for his IsAnnotative function. +;;;; +;;;; v5.0b 02-10-10 +;;;; Corrected wrong AutoCAD version number used to determine if ssget +;;;; filter should include Mleaders and Inserts objects. +;;;; +;;;; v5.0c 07-05-10 +;;;; Revised regular expression for Height format to include either upper or lower case x's +;;;; e.g. "\\H1.5x" or "\\H1.5X" +;;;; +;;;; GLOBALS LIST +;;;; +;;;; *REX* (blackboard) +;;;; *smt-acad* (blackboard) +;;;; *smt-doc* +;;;; *smt-blocks* +;;;; *smt-layers* +;;;; *smt-dclfilename* +;;;; *smt-smtver* +;;;; *sbar* +;;;; +;;;; C:SMT +;;;; C:StripMtext +;;;; StripMtext +;;;; StripMtextDCL +;;;; smt-acad +;;;; smt-doc +;;;; smt-blocks +;;;; smt-layers +;;;; +(vl-load-com) +(setq *smt-smtver* "5.0c") +;; How globals to objects are defined may change in future version +(defun smt-acad () + ;; Sets and returns global var referencing Acad ojbect + ;; Stores var in blackboard namespace + (cond ((vl-bb-ref '*smt-acad*)) + (t (vl-bb-set '*smt-acad* (vlax-get-acad-object))) + ) +) +(defun smt-doc () + ;; Sets and returns global var referencing doc object + (cond (*smt-doc*) + (t (setq *smt-doc* (vla-get-activedocument (smt-acad)))) + ) +) +(defun smt-blocks () + ;; Sets and returns global var referencing the blocks collection + (cond (*smt-blocks*) + (t (setq *smt-blocks* (vla-get-blocks (smt-doc)))) + ) +) +(defun smt-layers () + ;; Sets and returns global var referencing the layers collection + (cond (*smt-layers*) + (t (setq *smt-layers* (vla-get-layers (smt-doc)))) + ) +) + +;; +(defun c:StripMtext (/ *error* ss formats count acadver ssfilter) + ;; + ;; User command + ;; + (defun *error* (msg) + (vla-endundomark (smt-doc)) + (cond ((vl-position + msg + '("Function cancelled" "quit / exit abort" "console break") + ) + ) + ((princ (strcat "\nStripMtext Error: " msg))) + ) + ;; SD 12-20-09 vl-filename-mktemp not consistently deleting temp files + (if *smt-dclfilename* + (vl-file-delete *smt-dclfilename*) + ) + ;; Added JB 11/16/2009 Cmdecho is set to 0 in the StripMLeader function. + (setvar "cmdecho" 1) + (princ) + ) + ;; added version specific ssget filter SD 2-2-10 + (setq acadver (atof (getvar "acadver"))) + (setq ssfilter "MTEXT,DIMENSION") + (if (>= acadver 16.1) ;_Acad2005 + (setq ssfilter (strcat ssfilter ",ACAD_TABLE")) + ) + (if (>= acadver 17.1) ;_Acad2008 corrected ver num 2-10-10 + (setq ssfilter (strcat ssfilter ",MULTILEADER,INSERT")) + ) + (setq ssfilter (list (cons 0 ssfilter))) + ;; + (vla-startundomark (smt-doc)) + (setvar "cmdecho" 0) ;_ SD 2-0-10 + (prompt (strcat "\nStripMtext v" *smt-smtver*)) + (if (and (setq ss (ssget ;_ get selection + ":L" + ssfilter + ) + ) + (setq formats (StripMtextDCL)) ;_ get options + (setq count (StripMtext ss formats)) ;_ process + ) + (princ (strcat "\nStripMtext completed. " ;_ print report + (itoa count) + " objects processed." + ) + ) + (princ "\t*Cancel*") + ) + (setvar "cmdecho" 1) + (vla-endundomark (smt-doc)) + (princ) +) +(defun c:SMT () (c:StripMtext)) ;_shortcut +;;; +(defun StripMtextDCL (/ acadver dcl_id formats + keylist user regkey + _AcceptButton _ClearAllButton + _dclWrite _KeyToggle _RunDialog + _SelectAllButton + ) + ;; + ;; Function to create the DCL for StripMtext + ;; Arguments: None + ;; Returns: User input from DCL or nil + ;; + (defun _dclWrite (/ dclcode filename filehandle) + ;; Makes a temporary DCL file at runtime + ;; Returns name of the file or NIL + (setq dclcode + (list ;_ tilenames are case sensitive + "// Temporary DCL file" + (strcat "stripmtext" + ":dialog {label = \"StripMtext v" + *smt-smtver* + "\";" + ) + (strcat ":text { value = \"Removes formatting from " + "Mtext, Mleaders, Dimensions, Tables, & " + "Multiline Attributes\";}" + ) + "spacer_1; " + ":toggle {key = \"save\"; label = \"Remember Settings\";} " + "spacer_1; " + ":boxed_row {label = \"Select type of formatting to remove\";" + " :column { " + " :toggle {key = \"A\"; label = \"Alignment\";} " + " :toggle {key = \"C\"; label = \"Color\";} " + " :toggle {key = \"F\"; label = \"Font\";} " + " :toggle {key = \"H\"; label = \"Height\";} " + " :toggle {key = \"L\"; label = \"Linefeed\";} " + " :toggle {key = \"~\"; label = \"Nonbreaking~Space\";} " + " :toggle {key = \"Q\"; label = \"Oblique\";} " + " } " + " :column { " + " :toggle {key = \"O\"; label = \"Overline\";} " + " :toggle {key = \"P\"; label = \"Paragraph\";} " + " :toggle {key = \"S\"; label = \"Stacking\";} " + " :toggle {key = \"B\"; label = \"Tabs\";} " + " :toggle {key = \"T\"; label = \"Tracking\";} " + " :toggle {key = \"U\"; label = \"Underline\";} " + " :toggle {key = \"W\"; label = \"Width\";} " + " } " + " :column { " + " :toggle {key = \"M\"; label = \"Background Masks\";} " + " :toggle {key = \"D\"; label = \"Fields\";} " + " :toggle {key = \"N\"; label = \"Columns\";} " + " :spacer {height = 6.0;} " + " } " + " :column { " + " :button {key = \"selectall\"; label = \"Select All\";} " + " :button {key = \"clearall\"; label = \"Clear All\";} " + " :spacer {height = 6.0;} " + " } " + "} " + "errtile; " + "ok_cancel; " + "} " + ) + ) + ;; Revised temp file name 12-20-09 sd + (if (and (setq filename (vl-filename-mktemp "SMT" nil ".tmp")) + (setq filehandle (open filename "w")) + ) + (progn (foreach line dclcode (write-line line filehandle)) + (close filehandle) + ) + ) + filename + ) + (defun _SelectAllButton () + ;; Turn "on" all format toggle keys + ;; Requires global variable 'keylist + (mapcar '(lambda (key) (set_tile key "1")) keylist) + (set_tile "error" "") + (mode_tile "accept" 0) ;_ enable + (mode_tile "accept" 2) ;_ focus + ) + (defun _ClearAllButton () + ;; Turn "off" all format toggle keys + ;; Requires global variable 'keylist + (mapcar '(lambda (key) (set_tile key "0")) keylist) + (set_tile + "error" + "Select one or more formats to remove or press \"Cancel\" to exit" + ) + (mode_tile "accept" 1) ;_ disable + ) + (defun _AcceptButton (/ formats) + ;; Get and save user settings and exit dialog + ;; Requires global variables 'keylist and 'regkey + ;; Returns list of user chosen format keys + (setq formats (vl-remove-if + '(lambda (key) (= (get_tile key) "0")) + keylist + ) + ) + (vl-registry-write regkey "Save" (get_tile "save")) + (if (= (get_tile "save") "1") + (vl-registry-write regkey "Settings" (apply 'strcat formats)) + ) + (done_dialog 1) + formats + ) + (defun _KeyToggle () + ;; Turn on/off error message and enable/disable "ok" button + ;; Requires global variable 'keylist + (if (vl-some '(lambda (key) (= (get_tile key) "1")) keylist) + (progn (mode_tile "accept" 0) (set_tile "error" "")) + (progn + (mode_tile "accept" 1) + (set_tile + "error" + "Select one or more formats to remove or press \"Cancel\" to exit" + ) + ) + ) + ) + (defun _RunDialog (/ status formats) + ;; Display DCL with toggle preset with user's saved settings + ;; Creates default settings when routine is run on first time + ;; Requires global variables 'keylist, 'regkey, 'acaver, 'dcl_id + ;; Requires functions '_ClearAllButton, _SelectAllButton, _AcceptButton + ;; Returns list of chosen toggle/format keys if user exits DCL using Okay button + ;; Returns NIL if user exits using Cancel button + (set_tile "save" + (cond ((vl-registry-read regkey "Save")) + ((vl-registry-write regkey "Save" "1")) + ) + ) + (mapcar '(lambda (key) (set_tile key "1")) + (mapcar 'chr + (vl-string->list + (cond ((vl-registry-read regkey "Settings")) + ((vl-registry-write regkey "Settings" "CFH")) ;_ default + ) + ) + ) + ) + (if (> 16.1 acadver) ;_ disable fields & mask toggle keys + (progn (mode_tile "M" 1) (mode_tile "D" 1)) + ) + (if (> 17.1 acadver) ;_ disble mtext columns toggle key + (mode_tile "N" 1) + ) + ;; Define button callbacks and run dialog + (mapcar '(lambda (key) (action_tile key "(_KeyToggle)")) + keylist + ) + (action_tile "clearall" "(_ClearAllButton)") + (action_tile "selectall" "(_SelectAllButton)") + (action_tile "accept" "(setq formats (_AcceptButton))") + (action_tile "cancel" "(done_dialog 0)") + (setq status (start_dialog)) + (unload_dialog dcl_id) + ;; Added 12-20-09 sd Despite what the manual says, vl-filename-mktemp + ;; files were not always being automatically deleted + (vl-file-delete *smt-dclfilename*) + ;; If status = 1 , then Accept button hit + (if (= status 1) + formats + ) + ) ;_ RunDialog + ;; + ;; Begin main DCL routine + ;; + (setq regkey "HKEY_CURRENT_USER\\SOFTWARE\\StripMtext\\" + acadver (atof (getvar "acadver")) + keylist (append (if (<= 15.0 acadver) ;_ vlisp required 2000 + '("A" "B" "C" "F" "H" "L" "O" + "Q" "P" "S" "T" "U" "W" "~" + ) + ) + (if (<= 16.1 acadver) ;_ fields, mask, tables 2005 + '("M" "D") + ) + (if (<= 17.1 acadver) ;_ mtext columns added 2008 + '("N") + ) + ) + ) + (cond ;; Exit routine if not running in Acad 2000 or above + ((not keylist) + (alert "StripMtext Error:\nRequires AutoCAD 2000 or higher") + ) + ;; Create DCL file + ((null (setq *smt-dclfilename* (_dclwrite))) + (alert "StripMtext Error:\nUnable to write DCL file") + ) + ;; Exit if cannot find DCL file + ((< (setq dcl_id (load_dialog *smt-dclfilename*)) 0) + (alert (strcat "StripMtext Error:\nCannot load DCL file:\n" + *smt-dclfilename* + ) + ) + ) + ;; Exit if DCL fails to load + ((not (new_dialog "stripmtext" dcl_id)) + (alert "StripMtext Error:\nCannot display dialog") + ) + ;; Run DCL and return user's chosen formats + ((_RunDialog)) + ) +) +;;; +(defun StripMtext + (ss formats / mtextobjlst mldrobjlst dimobjlst tableobjlst layers + mattobjlst obj objname str cnt spinflag lockedcellflag + ;; functions + Spinbar FormatsToList StripFormat StripColumn StripMask + StripField StripTableFields StripTable StripMLeader + StripMAttribute RowsColumns CellFieldOwner SymbolString + GetFields IsAnnotative GetAnnoScales) + + ;;; + ;;; StripMtext + ;;; + ;;; Parses supplied list of format keys and selection set to determine which + ;;; Strip* function to operate on which entities. Iterates through selected + ;;; objects and passes appropriate arguments to appropriate Strip* function + ;;; + ;;; Returns count of entities processed + ;;; + ;;; 'ss argument is a pickset containing valid entities + ;;; 'formats argument is a list of format keys: '("A" "C" ... "F") + ;;; or a string of format keys: "ACF" + ;;; + ;;; For more info on syntax and valid arugments, please refer to + ;;; "HOW TO USE BY SCRIPT OR AUTOLISP" in header comments at top of file, + ;;; or read through comments in subs below. + ;;; + ;;; Powered by Joe Burke's stripping functions: + ;;; + ;;; StripColumn + ;;; StripField + ;;; StripFormat + ;;; StripMask + ;;; StripMAttribute + ;;; StripMLeader + ;;; StripTable + ;;; StripTableFields + ;;; SymbolString + ;;; CellFieldOwner + ;;; FormatsToList + ;;; GetFields + ;;; RowsColumns + ;;; IsAnnotative + ;;; GetAnnoScales + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; Define Stripping functions ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Argument: either a list of strings or a string. + ;; Given a list, ensure formats are uppercase. + ;; Given a formats string, convert it to a list of uppercase strings. + ;; Examples: (FormatsToList "fOU") > ("F" "O" "U") + ;; (FormatsToList "f^OU") > ("F" "^O" "U") + (defun FormatsToList (arg / lst) + (cond + ((= (type arg) 'LIST) + (mapcar 'strcase arg) + ) + ((= (type arg) 'STR) + (while (not (eq "" (substr arg 1))) + (if (eq "^" (substr arg 1 1)) + (setq lst (cons (strcat "^" (substr arg 2 1)) lst) + arg (substr arg 3) + ) + (setq lst (cons (substr arg 1 1) lst) + arg (substr arg 2) + ) + ) + ) + (mapcar 'strcase (reverse lst)) + ) + ) + ) ; end FormatsToList + + ;; Arguments: + ;; str - an mtext string. + ;; formats - a list of format code strings or a string. + ;; Format code arguments are not case sensitive. + + ;; Examples: + ;; Remove Font, Overline and Underline formatting. + ;; (StripFormat (list "f" "O" "U")) + ;; Or a quoted list: + ;; (StripFormat '("f" "O" "U")) + ;; Or a string: + ;; (StripFormat "fOU") + + ;; Remove all formatting except Overline and Underline. + ;; (StripFormat (list "*" "^O" "^U")) + ;; Or a quoted list: + ;; (StripFormat '("*" "^O" "^U")) + ;; Or a string: + ;; (StripFormat "*^O^U") + + ;; Available codes: + ;; A (^A) - Alignment + ;; B (^B) - taBs + ;; C (^C) - Color + ;; F (^F) - Font + ;; H (^H) - Height + ;; L (^L) - Linefeed (newline, line break, carriage return) + ;; O (^O) - Overline + ;; Q (^Q) - obliQuing + ;; P (^P) - Paragraph (embedded justification, line spacing and indents) + ;; S (^S) - Stacking + ;; T (^T) - Tracking + ;; U (^U) - Underline + ;; W (^W) - Width + ;; ~ (^~) - non-breaking space + ;; * - all formats + + (defun StripFormat (str formats / text slashflag lbrace rbrace + RE:Replace RE:Execute Alignment Tab Color + Font Height Linefeed Overline Paragraph Oblique + Stacking Tracking Underline Width Braces HardSpace) + + (setq formats (FormatsToList formats)) + + ;; Access the RegExp object from the blackboard. + ;; Thanks to Steve for this idea. + (or + (vl-bb-ref '*REX*) + (vl-bb-set '*REX* (vlax-create-object "VBScript.RegExp")) + ) + (defun RE:Replace (newstr pat string) + (vlax-put (vl-bb-ref '*REX*) 'Pattern pat) + (vlax-put (vl-bb-ref '*REX*) 'Global actrue) + (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse) + (vlax-invoke (vl-bb-ref '*REX*) 'Replace string newstr) + ) ;end + (defun RE:Execute (pat string / result match idx lst) + (vlax-put (vl-bb-ref '*REX*) 'Pattern pat) + (vlax-put (vl-bb-ref '*REX*) 'Global actrue) + (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse) + (setq result (vlax-invoke (vl-bb-ref '*REX*) 'Execute string)) + (vlax-for x result + (setq match (vlax-get x 'Value) + idx (vlax-get x 'FirstIndex) + ;; position within string - zero based - first position is zero + lst (cons (list match idx) lst) + ) + ) + lst + ) ;end + + ;; Replace linefeeds using this format "\n" with the AutoCAD + ;; standard format "\P". The "\n" format occurs when text is + ;; copied to ACAD from some other application. + (setq str (RE:Replace "\\P" "\\n" str)) + + ;;;;; Start remove formatting sub-functions ;;;;; + ;; A format + (defun Alignment (str) (RE:Replace "" "\\\\A[012];" str)) + ;; B format (tabs) + (defun Tab (str / lst origstr tempstr) + (setq lst (RE:Execute "\\\\P\\t|[0-9]+;\\t" str)) + (foreach x lst + (setq origstr (car x) + tempstr (RE:Replace "" "\\t" origstr) + str (vl-string-subst tempstr origstr str) + ) + ) + (RE:Replace " " "\\t" str) + ) + ;; C format + (defun Color (str) + ;; True color and color book integers are preceded + ;; by a lower case "c". Standard colors use upper case "C". + (RE:Replace "" "\\\\[Cc][0-9]?[.]?[0-9]+;" str) + ) + ;; F format + (defun Font (str) (RE:Replace "" "\\\\[Ff].*?;" str)) + ;; H format + (defun Height (str) + ;; revised 6/6/2010 + ;(RE:Replace "" "\\\\H[0-9]?[.]?[0-9]+x;" str) + (RE:Replace "" "\\\\H[0-9]*?[.]?[0-9]*?(x|X)+;" str) + ) + ;; L format + ;; Leading linefeeds are not converted to spaces. + (defun Linefeed (str / teststr) + ;; Remove formatting from test string other than linefeeds. + ;; Seems there's no need to check for stacking + ;; because a linefeed will always come before stack formatting. + (setq teststr (Alignment str) + teststr (Color teststr) + teststr (Font teststr) + teststr (Height teststr) + teststr (Overline teststr) + teststr (Paragraph teststr) + teststr (Oblique teststr) + teststr (Tracking teststr) + teststr (Underline teststr) + teststr (Width teststr) + teststr (Braces teststr) + ) + ;; Remove leading linefeeds. + (while (eq "\\P" (substr teststr 1 2)) + (setq teststr (substr teststr 3) + str (vl-string-subst "" "\\P" str) + ) + ) + (RE:Replace " " " \\\\P|\\\\P |\\\\P" str) + ) + ;; O format + (defun Overline (str) (RE:Replace "" "\\\\[Oo]" str)) + ;; This option is effectively the same as the Remove Formatting > + ;; Remove Paragraph Formatting option avaiable in the 2008 Mtext editor. + (defun Paragraph (str) (RE:Replace "" "\\\\p.*?;" str)) + ;; Q format - numeric value may be negative. + (defun Oblique (str) + ;; Any real number including negative values. + (RE:Replace "" "\\\\Q[-]?[0-9]*?[.]?[0-9]+;" str) + ) + ;; S format + (defun Stacking (str / lst tempstr pos origstr teststr testpos numcheck) + (setq lst (RE:Execute "\\\\S(.*?)(\\;)" str)) + (foreach x lst + (setq tempstr (car x) + pos (cadr x) + origstr tempstr + ) + ;; Remove formatting from test string other than stacking. + (setq teststr (Alignment str) + teststr (Color teststr) + teststr (Font teststr) + teststr (Height teststr) + teststr (Linefeed teststr) + teststr (Overline teststr) + teststr (Paragraph teststr) + teststr (Oblique teststr) + teststr (Tracking teststr) + teststr (Underline teststr) + teststr (Width teststr) + teststr (Braces teststr) + ) + ;; Remove all "{" characters if present. Added JB 2/1/2010. + (setq teststr (RE:Replace "" "[{]" teststr)) + ;; Get the stacked position within test string. + (setq testpos (cadar (RE:Execute "\\\\S(.*?)(\\;)" teststr))) + ;; Avoid an error with substr if testpos is zero. + ;; A space should not be added given a stacked + ;; fraction string which is simply like this 1/2" anyway. + (if (/= 0 testpos) + (setq numcheck (substr teststr testpos 1)) + ) + ;; Check whether the character before a stacked string/fraction + ;; is a number. Add a space if it is. + (if + (and + numcheck + (<= 48 (ascii numcheck) 57) + ) + (setq tempstr (RE:Replace " " "\\\\S" tempstr)) + (setq tempstr (RE:Replace "" "\\\\S" tempstr)) + ) + (setq tempstr (RE:Replace "/" "[#]" tempstr) + tempstr (RE:Replace "" "[;]" tempstr) + tempstr (RE:Replace "" "\\\\A(.*?)[;]" tempstr) + tempstr (RE:Replace "" "\\^" tempstr) + str (vl-string-subst tempstr origstr str pos) + ) + ) + str + ) + ;; T format + (defun Tracking (str) (RE:Replace "" "\\\\T[0-9]?[.]?[0-9]+;" str)) + ;; U format + (defun Underline (str) (RE:Replace "" "\\\\[Ll]" str)) + ;; W format + (defun Width (str) (RE:Replace "" "\\\\W[0-9]?[.]?[0-9]+;" str)) + ;; ~ format + ;; In 2008 a hard space includes font formatting. + ;; In 2004 it does not, simply this \\~. + (defun HardSpace (str) (RE:Replace " " "{\\\\[Ff](.*?)\\\\~}|\\\\~" str)) + ;; Remove curly braces. Called after other formatting is removed. + (defun Braces (str / lst origstr tempstr len teststr) + (setq lst (RE:Execute "{[^\\\\]+}" str)) + (foreach x lst + (setq origstr (car x) + tempstr (RE:Replace "" "[{}]" origstr) + str (vl-string-subst tempstr origstr str) + ) + ) + ;; Added JB 12/20/2009 + ;; Last ditch attempt at remove braces from start and end of string. + (setq len (strlen str)) + (if + (and + (= 123 (ascii (substr str 1 1))) + (= 125 (ascii (substr str len 1))) + (setq teststr (substr str 2)) + (setq teststr (substr teststr 1 (1- (strlen teststr)))) + (not (vl-string-search "{" teststr)) + (not (vl-string-search "}" teststr)) + ) + (setq str teststr) + ) + str + ) + + ;;;;; End remove formatting sub-functions ;;;;; + ;;;;; Start primary function ;;;;; + ;; Temporarily replace literal backslashes with a unique string. + ;; Literal backslashes are restored at end of function. By Steve Doman. + (setq slashflag (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) ">")) + (setq text (RE:Replace slashflag "\\\\\\\\" str)) + ;; Temporarily replace literal left curly brace. + (setq lbrace (strcat "")) + (setq text (RE:Replace lbrace "\\\\{" text)) + ;; Temporarily replace literal right curly brace. + (setq rbrace (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) "R>")) + (setq text (RE:Replace rbrace "\\\\}" text)) + + (if (or (vl-position "A" formats) + (and (vl-position "*" formats) (not (vl-position "^A" formats))) + ) + (setq text (Alignment text)) + ) + (if (or (vl-position "B" formats) + (and (vl-position "*" formats) (not (vl-position "^B" formats))) + ) + (setq text (Tab text)) + ) + (if (or (vl-position "C" formats) + (and (vl-position "*" formats) (not (vl-position "^C" formats))) + ) + (setq text (Color text)) + ) + (if (or (vl-position "F" formats) + (and (vl-position "*" formats) (not (vl-position "^F" formats))) + ) + (setq text (Font text)) + ) + (if (or (vl-position "H" formats) + (and (vl-position "*" formats) (not (vl-position "^H" formats))) + ) + (setq text (Height text)) + ) + (if (or (vl-position "L" formats) + (and (vl-position "*" formats) (not (vl-position "^L" formats))) + ) + (setq text (Linefeed text)) + ) + (if (or (vl-position "O" formats) + (and (vl-position "*" formats) (not (vl-position "^O" formats))) + ) + (setq text (Overline text)) + ) + (if (or (vl-position "P" formats) + (and (vl-position "*" formats) (not (vl-position "^P" formats))) + ) + (setq text (Paragraph text)) + ) + (if (or (vl-position "Q" formats) + (and (vl-position "*" formats) (not (vl-position "^Q" formats))) + ) + (setq text (Oblique text)) + ) + (if (or (vl-position "S" formats) + (and (vl-position "*" formats) (not (vl-position "^S" formats))) + ) + (setq text (Stacking text)) + ) + (if (or (vl-position "T" formats) + (and (vl-position "*" formats) (not (vl-position "^T" formats))) + ) + (setq text (Tracking text)) + ) + (if (or (vl-position "U" formats) + (and (vl-position "*" formats) (not (vl-position "^U" formats))) + ) + (setq text (Underline text)) + ) + (if (or (vl-position "W" formats) + (and (vl-position "*" formats) (not (vl-position "^W" formats))) + ) + (setq text (Width text)) + ) + (if (or (vl-position "~" formats) + (and (vl-position "*" formats) (not (vl-position "^~" formats))) + ) + (setq text (HardSpace text)) + ) + (setq text (Braces (RE:Replace "\\\\" slashflag text)) + text (RE:Replace "\\{" lbrace text) + text (RE:Replace "\\}" rbrace text) + ) + text + ) ; end StripFormat + + ;; Added JB 1/27/2010. Used in the StripColumn function below. + ;; by Ian Bryant + ;; Return T if ename is annotative, otherwise nil. + (defun IsAnnotative (e) + (and e + (setq e (cdr (assoc 360 (entget e)))) + (setq e (dictsearch e "AcDbContextDataManager")) + (setq e (dictsearch (cdr (assoc -1 e)) "ACDB_ANNOTATIONSCALES")) + (assoc 350 e) + ) + ) ;end IsAnnotative + + ;; Added JB 1/27/2010. Used in the StripColumn function below. + ;; Argument: the ename of an annotative object. + ;; Returns: a list of annotative scales or nil if the object is + ;; not annotative. + (defun GetAnnoScales (e / dict lst rewind res) + (if + (and + e + (setq dict (cdr (assoc 360 (entget e)))) + (setq lst (dictsearch dict "AcDbContextDataManager")) + (setq lst (dictsearch (cdr (assoc -1 lst)) "ACDB_ANNOTATIONSCALES")) + (setq dict (cdr (assoc -1 lst))) + ) + (progn + (setq rewind T) + (while (setq lst (dictnext dict rewind)) + (setq e (cdr (assoc 340 lst)) + res (cons (cdr (assoc 300 (entget e))) res) + rewind nil + ) + ) + ) + ) + (reverse res) + ) ; end GetAnnoScales + + ;; Mtext columns were added in AutoCAD 2008. + ;; Remove column formatting from an mtext object. + ;; Argument: mtext vla-object. + ;; Note: Though the DXF 75 code referenced here does not appear in an + ;; entget mtext ename call, it can be used to removed column formatting. + ;; See DXF Reference for mtext objects in 2008 or later. + (defun StripColumn (obj / ename sclst) + (if + (and + (>= (atof (getvar "AcadVer")) 17.1) + (eq "AcDbMText" (vlax-get obj 'ObjectName)) + (setq ename (vlax-vla-object->ename obj)) + ) + (cond + ;; Added JB 1/26/2010. + ;; Allows columns to be removed from annotative objects. + ((and + (IsAnnotative ename) + (setq sclst (GetAnnoScales ename)) + ) + (setvar "cmdecho" 0) + (command "._chprop" ename "" "_Annotative" "_No" "") + (entmod (append (entget ename) '((75 . 0)))) + (command "._chprop" ename "" "_Annotative" "_Yes" "") + (foreach x sclst + (command "._objectscale" ename "" "_Add" x "") + ) + (setvar "cmdecho" 1) + ) + ;; For non-annotative objects. + (T + (entmod (append (entget ename) '((75 . 0)))) + ) + ) + ) + ) ; end StripColumn + + ;; Background mask for mtext objects was added in AutoCAD 2005. + ;; Remove background mask from mtext and multileader objects. + ;; Argument: an mtext or multileader ename or vla-object. + ;; Added support for dimensions. + (defun StripMask (obj / frame elst maskcode str mbw) + (cond + ((and + (eq "AcDbMText" (vlax-get obj 'ObjectName)) + (vlax-property-available-p obj 'BackgroundFill) + ) + (vlax-put obj 'BackgroundFill 0) + ) + ((and + (wcmatch (vlax-get obj 'ObjectName) "*Dimension*") + (vlax-property-available-p obj 'TextFill) + ) + (vlax-put obj 'TextFill 0) + ) + ((and + (eq "AcDbMLeader" (vlax-get obj 'ObjectName)) + (vlax-property-available-p obj 'TextFrameDisplay) + (setq frame (vlax-get obj 'TextFrameDisplay)) + (setq elst (entget (vlax-vla-object->ename obj))) + (setq maskcode (assoc 292 elst)) + (/= 0 (cdr maskcode)) + (entmod (subst (cons 292 0) maskcode elst)) + ) + (vlax-put obj 'TextFrameDisplay frame) + ) + ;; Preserve fields. + ((and + (eq "AcDbAttribute" (vlax-get obj 'ObjectName)) + ;; check for 90 mask code + (assoc 90 (entget (vlax-vla-object->ename obj))) + ) + (if + ;; If the attribute does not have an extension dictionary or + ;; the dictionary can be deleted because it is empty. + (or + (= 0 (vlax-get obj 'HasExtensionDictionary)) + (not + (vl-catch-all-error-p + (vl-catch-all-apply 'vlax-invoke + (list (vlax-invoke obj 'GetExtensionDictionary) 'Delete) + ) + ) + ) + ) + (setq str (SymbolString obj)) + (setq str (GetFields obj nil)) + ) + (setq mbw (vlax-get obj 'MTextBoundaryWidth)) + (vlax-put obj 'MTextAttribute 0) + (vlax-put obj 'MTextAttribute -1) + (vlax-put obj 'TextString str) + (vlax-put obj 'MTextBoundaryWidth mbw) + ) + ) + ) ; end StripMask + + ;; Fields were added in AutoCAD 2005. + ;; Remove the fields dictionary from supported object types if it exists. + ;; Argument: mtext, multiline attribute, mleader or dimension vla-object. + ;; Returns: the object TextString with symbols intact. + (defun StripField (obj / typ str dict) + (setq typ (vlax-get obj 'ObjectName)) + (if + (or + (eq typ "AcDbMText") + (eq typ "AcDbAttribute") + ) + (setq str (SymbolString obj)) + ) + ;; Added JB 1/29/2008 to fix a problem with fields in multiline + ;; attributes which do not update correctly when undo is called + ;; afer running StripMtext. + (if (eq typ "AcDbAttribute") + (command "._updatefield" (vlax-vla-object->ename obj) "") + ) + (and (= -1 (vlax-get obj 'HasExtensionDictionary)) + (not + (vl-catch-all-error-p + (setq dict (vl-catch-all-apply 'vlax-invoke + (list obj 'GetExtensionDictionary)) + ) + ) + ) + (not + (vl-catch-all-error-p + (vl-catch-all-apply 'vlax-invoke (list dict 'Remove "ACAD_FIELD")) + ) + ) + (not (vl-catch-all-error-p + (vl-catch-all-apply 'vlax-invoke (list dict 'Delete)) + ) + ) + str + (vl-catch-all-apply 'vlax-put (list obj 'TextString str)) + ) + ;; Added 11/14/2009. Return str to StripTableField function. + str + ) ; end StripField + + (defun StripTableFields (obj / rows columns rclst row col mtxtobj str) + (setq rows (vlax-get obj 'Rows) + columns (vlax-get obj 'Columns) + rclst (RowsColumns rows columns) + ) + (vla-put-RegenerateTableSuppressed obj :vlax-true) + (foreach x rclst + (setq row (car x) col (cadr x)) + (cond + ;; Revised JB 1/4/2010. + ;; Cell is not a text cell. + ((/= 1 (vlax-invoke obj 'GetCellType row col))) + ;; Revised JB 1/21/2010 + ;; Cell is locked in 2008 or later. Apparently cells cannot + ;; be locked in versions prior to 2008. + ((and + (vlax-method-applicable-p obj 'GetCellState) + (/= 0 (vlax-invoke obj 'GetCellState row col)) + ) + (setq lockedcellflag T) + ) + ((and + (setq mtxtobj (CellFieldOwner obj row col)) + (setq str (StripField mtxtobj)) + ) + (vlax-invoke obj 'SetText row col str) + ) + ) + ) + (vla-put-RegenerateTableSuppressed obj :vlax-false) + ) ; end StripTableFields + + (defun StripTable (obj formats / blocks blkname blkobj rclst row col + str getstr mtxtobjlst temprclst) + (setq blocks (smt-blocks)) + (setq blkname (cdr (assoc 2 (entget (vlax-vla-object->ename obj))))) + (setq blkobj (vla-item blocks blkname)) + (vlax-for x blkobj + (if + (and + (eq "AcDbMText" (vlax-get x 'ObjectName)) + (not (eq "" (vlax-get x 'TextString))) + ) + (setq mtxtobjlst (cons x mtxtobjlst)) + ) + ) + (setq rclst (RowsColumns (vlax-get obj 'Rows) (vlax-get obj 'Columns))) + (foreach x rclst + (setq row (car x) col (cadr x)) + (if + (and + (vlax-method-applicable-p obj 'GetCellState) + (/= 0 (vlax-invoke obj 'GetCellState row col)) + ) + (setq lockedcellflag T) + ) + (if (not (eq "" (vlax-invoke obj 'GetText row col))) + (setq temprclst (cons x temprclst)) + ) + ) + (vla-put-RegenerateTableSuppressed obj acTrue) + ;; The equal test may be temporary. Not sure yet. + ;; Revised JB 1/24/2010. + (if (= (length mtxtobjlst) (length temprclst)) + (foreach x mtxtobjlst + (setq str (SymbolString x)) + (setq row (caar temprclst) col (cadar temprclst)) + (setq str (StripFormat str formats)) + (vlax-put x 'TextString str) + (setq str (vlax-invoke x 'FieldCode)) + (vl-catch-all-apply 'vlax-invoke + (list obj 'SetText row col str) + ) + ;; Step through the list. + (setq temprclst (cdr temprclst)) + ) + ) + (vla-put-RegenerateTableSuppressed obj acFalse) + ) ; end StripTable + + (defun StripMLeader (obj formats) + (if + ;; If the mleader does not have an extension dictionary or + ;; the dictionary can be deleted because it is empty. + (or + (= 0 (vlax-get obj 'HasExtensionDictionary)) + (not + (vl-catch-all-error-p + (vl-catch-all-apply 'vlax-invoke + (list (vlax-invoke obj 'GetExtensionDictionary) 'Delete) + ) + ) + ) + ) + (vlax-put obj 'TextString (StripFormat (SymbolString obj) formats)) + (progn + (vlax-put obj 'TextString (GetFields obj formats)) + (setvar "cmdecho" 0) + (vl-cmdf "._updatefield" (vlax-vla-object->ename obj) "") + (setvar "cmdecho" 1) + (vla-update obj) + (vlax-put obj 'TextFrameDisplay (vlax-get obj 'TextFrameDisplay)) + ) + ) + ) ; end StripMLeader + + ;; Arguments: multiline attribute vla-object and a list of formats to remove. + (defun StripMAttribute (obj formats) + (if + ;; If the attribute does not have an extension dictionary or + ;; the dictionary can be deleted because it is empty. + (or + (= 0 (vlax-get obj 'HasExtensionDictionary)) + (not + (vl-catch-all-error-p + (vl-catch-all-apply 'vlax-invoke + (list (vlax-invoke obj 'GetExtensionDictionary) 'Delete) + ) + ) + ) + ) + (vlax-put obj 'TextString (StripFormat (SymbolString obj) formats)) + (progn + (vlax-put obj 'TextString (GetFields obj formats)) + (vla-update obj) + ) + ) + ) ; end StripMAttribute + + ;; Arguments: number of rows and columns in a table. + ;; Example: (rowscolumns 2 3) > ((0 0) (1 0) (0 1) (1 1) (0 2) (1 2)) + ;; Revised 11/13/2009 to return the list first reading left to right and + ;; then top to bottom like this ((0 0) (0 1) (0 2) (1 0) (1 1) (1 2)) + (defun RowsColumns (r c / n clst rlst lst) + (setq n 0) + (while (< n r) + (setq rlst (cons n rlst)) + (setq n (1+ n)) + ) + (setq n 0) + (while (< n c) + (setq clst (cons n clst)) + (setq n (1+ n)) + ) + (foreach r rlst + (foreach c clst + (setq lst (cons (list r c) lst)) + ) + ) + ) ; end RowsColumns + + ;; Thanks to James Allen for pointing out the GetFieldID method. + ;; Arguments: table vla-object, row and column. + ;; Returns: the mtext object if the cell contains a field, otherwise nil. + (defun CellFieldOwner (tblobj row col / doc id owner) + (setq doc (smt-doc)) + (and + (setq id (vlax-invoke tblobj 'GetFieldID row col)) + (/= 0 id) + (setq owner (vlax-invoke doc 'ObjectIDtoObject id)) + (repeat 3 + (setq owner + (vlax-invoke doc 'ObjectIDtoObject (vlax-get owner 'OwnerID)) + ) + ) + ) + owner + ) ; end CellFieldOwner + + ;; Argument: ename or vla-object. + ;; Object types: mtext, attribute, mleader or dimension. + ;; Returns: a string with symbols intact. + (defun SymbolString (obj / e typ str name String blocks) + ;; A multiline attributue may contain two 1 DXF codes and multiple + ;; 3 DXF codes. In either case the first code 1 should be ingored + ;; since it contains a string which is not displayed on screen. + ;; Apparently this odd condition occurs when text is pasted on top + ;; of existing text. The old text is stored in the first DXF code 1 + ;; and the text displayed on screen is stored in the second DXF code 1. + (defun String (ename / str lst) + (setq str "") + (setq lst + (vl-remove-if-not + '(lambda (x) (or (= 3 (car x)) (= 1 (car x)))) (entget ename) + ) + ) + (if (and (< 1 (length lst)) (= 1 (caar lst))) + (setq lst (cdr lst)) + ) + (foreach x lst + (setq str (strcat str (cdr x))) + ) + ) ; end String + + (if (= (type obj) 'VLA-OBJECT) + (setq e (vlax-vla-object->ename obj)) + (progn + (setq e obj) + (setq obj (vlax-ename->vla-object obj)) + ) + ) + (setq typ (vlax-get obj 'ObjectName)) + (cond + ((or + (eq typ "AcDbMText") + (eq typ "AcDbAttribute") + ) + (setq str (String e)) + ) + ((eq typ "AcDbMLeader") + (setq str (cdr (assoc 304 (entget e)))) + ) + ;; Revised SD 1/15/2010. Looks good JB 1/19/2010. + ((wcmatch typ "*Dimension*") + (setq str (cdr (assoc 1 (entget e)))) + ) + ) + str + ) ; end SymbolString + + ;; Argument: multiline attribute or mleader vla-object. + ;; Called by StripMAttribute and StripMLeader sub-functions. + ;; Also called by StripMask to preserve fields in a multiline attribute. + ;; Those functions check the the object has a dictionary or not. + ;; This is a revised version of a St:GetFields from SwapText.lsp. + ;; Returns: the same string as the FieldCode method with formatting + ;; removed. Returns the source text string with formatting removed + ;; if no fields are found in an attribute or mleader. + ;; Note, FieldCode does not work with attributes or mleaders. + ;; Create a new temporary mtext object. Apply source field dictionaries + ;; to it. Then get the FieldCode from temp object and erase it. + (defun GetFields (obj formats / srcdict srcdictename srcTEXTdict + srcfieldename targdict targdictename + fieldelst fielddict dicts actlay + tempobj lockflag res doc) + (setq doc (smt-doc)) + (if + (and + (= -1 (vlax-get obj 'HasExtensionDictionary)) + (setq srcdict (vlax-invoke obj 'GetExtensionDictionary)) + (setq srcdictename (vlax-vla-object->ename srcdict)) + (setq srcTEXTdict (dictsearch srcdictename "ACAD_FIELD")) + (setq srcfieldename (cdr (assoc 360 srcTEXTdict))) + ) + (progn + ;; Check for active layer locked. + (setq actlay (vlax-get doc 'ActiveLayer)) + (if (= -1 (vlax-get actlay 'Lock)) + (progn + (vlax-put actlay 'Lock 0) + (setq lockflag T) + ) + ) + (setq tempobj + (vlax-invoke + (vlax-get (vla-get-ActiveLayout doc) 'Block) + 'AddMText '(0.0 0.0 0.0) 0.0 "x" + ) + ) + (setq targdict (vlax-invoke tempobj 'GetExtensionDictionary) + targdictename (vlax-vla-object->ename targdict) + fieldelst (entget srcfieldename) + ;; not sure about the need for these + fieldelst (vl-remove (assoc 5 fieldelst) fieldelst) + fieldelst (vl-remove (assoc -1 fieldelst) fieldelst) + fieldelst (vl-remove (assoc 102 fieldelst) fieldelst) + fieldelst (vl-remove-if '(lambda (x) (= 330 (car x))) fieldelst) + ) + (foreach x fieldelst + (if (= 360 (car x)) + (progn + (setq dicts (cons (cdr x) dicts)) + ) + ) + ) + ;; remove all 360s from fieldelst + (setq fieldelst (vl-remove-if '(lambda (x) (= 360 (car x))) fieldelst)) + (foreach x (reverse dicts) + (setq fieldelst + (append fieldelst (list (cons 360 (entmakex (entget x))))) + ) + ) + (setq fielddict + (dictadd targdictename "ACAD_FIELD" + (entmakex + '( + (0 . "DICTIONARY") + (100 . "AcDbDictionary") + (280 . 1) + (281 . 1) + ) + ) + ) + ) + (dictadd fielddict "TEXT" + (entmakex fieldelst) + ) + ;; Revised 11/23/2009. + (vlax-put tempobj 'TextString + (StripFormat (SymbolString tempobj) formats) + ) + (setq res (vlax-invoke tempobj 'FieldCode)) + (vla-delete tempobj) + (if lockflag (vlax-put actlay 'Lock -1)) + ) ; progn + ;; Else return the text string with formatting removed. + ;; Unlikely this would be used. + (setq res (StripFormat (SymbolString obj) formats)) + ) ; if + res + ) ; end GetFields + + ;; Author unknown. + (defun Spinbar (sbar) + (cond ((= sbar "\\") "|") + ((= sbar "|") "/") + ((= sbar "/") "-") + (t "\\") + ) + ) ;_end spinbar + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; Begin Main StripMtext function ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (vl-load-com) + (setq formats (FormatsToList formats)) + (setq layers (smt-layers)) + + ;; Sort the selection set to lists by object type. + (setq cnt 0) + (repeat (sslength ss) + (setq obj (vlax-ename->vla-object (ssname ss cnt)) + objname (vlax-get-property obj "ObjectName") + cnt (1+ cnt) + ) + (cond + ((eq objname "AcDbMText") ;_ Mtext AutoCAD R13+ + (setq mtextobjlst (cons obj mtextobjlst)) + ) + ((and (eq objname "AcDbMLeader") ;_ Mleader AutoCAD 2008+ + (vlax-property-available-p obj 'ContentType) + (= 2 (vlax-get obj 'ContentType)) + ) + (setq mldrobjlst (cons obj mldrobjlst)) + ) + ((and (eq objname "AcDbBlockReference") ;_ Multiline Atts AutoCAD 2008+ + (vlax-property-available-p obj 'HasAttributes) + (= -1 (vlax-get obj 'HasAttributes)) + (vlax-method-applicable-p obj 'GetAttributes) + ) + (foreach x (vlax-invoke obj 'GetAttributes) + (if + (and (vlax-property-available-p x 'MTextAttribute) + (= -1 (vlax-get x 'MTextAttribute)) + (= 0 + (vlax-get (vla-item layers (vlax-get x 'Layer)) 'Lock) + ) + ) + (setq mattobjlst (cons x mattobjlst)) + ) + ) + ) + ((vl-position + objname + '("AcDbAlignedDimension" + "AcDbRotatedDimension" + "AcDbOrdinateDimension" + "AcDsbAngularDimension" + "AcsDb2LineAngularDimension" + "AcDb3PointAngularDimension" + "AscDbDiametricDimension" + "AcDbRadialDimension" + "AcDbRadialDimensionLarge" + "AcDbArcDimension" + ) + ) + (setq dimobjlst (cons obj dimobjlst)) + ) + ((eq objname "AcDbTable") ;_ AutoCAD 2005+ + (setq tableobjlst (cons obj tableobjlst)) + ) + ) + ) + ;; + ;; Parse format list and invoke Strip* functions w/ appropriate arguments + ;; + (if (or (vl-position "*" formats) (vl-position "D" formats)) + (progn (foreach x mtextobjlst (StripField x)) + (foreach x mldrobjlst (StripField x)) + (foreach x dimobjlst (StripField x)) + (foreach x mattobjlst (StripField x)) + (foreach x tableobjlst (StripTableFields x)) + ) + ) + (if (or (vl-position "*" formats) (vl-position "N" formats)) + (foreach x mtextobjlst (StripColumn x)) + ) + (if (or (vl-position "*" formats) (vl-position "M" formats)) + (progn (foreach x mtextobjlst (StripMask x)) + (foreach x mldrobjlst (StripMask x)) + (foreach x dimobjlst (StripMask x)) + (foreach x mattobjlst (StripMask x)) + ) + ) + (if (setq formats (vl-remove-if + '(lambda (key) + (vl-position key '("M" "D" "N" "^M" "^D" "^N")) + ) + formats + ) + ) + (progn + (setq spinflag (> (length mtextobjlst) 100)) + (foreach x mtextobjlst + (setq str (StripFormat (SymbolString x) formats)) + (vlax-put x 'TextString str) + (if spinflag + (princ (strcat "\rProcessing... " + (setq *sbar* (Spinbar *sbar*)) + "\t" + ) + ) + ) + ) + (setq spinflag (> (length mldrobjlst) 100)) + (foreach x mldrobjlst + (StripMLeader x formats) + (if spinflag + (princ (strcat "\rProcessing... " + (setq *sbar* (Spinbar *sbar*)) + "\t" + ) + ) + ) + ) + (setq spinflag (> (length dimobjlst) 100)) + (foreach x dimobjlst + (setq str (StripFormat (SymbolString x) formats)) + (vlax-put-property x 'TextOverride str) + ;; Added JB 1/19/2010. Updates the dimension object + ;; which is needed in some cases. + (entget (vlax-vla-object->ename x)) + (if spinflag + (princ (strcat "\rProcessing... " + (setq *sbar* (Spinbar *sbar*)) + "\t" + ) + ) + ) + ) + (setq spinflag (> (length mattobjlst) 100)) + (foreach x mattobjlst + (StripMAttribute x formats) + (if spinflag + (princ (strcat "\rProcessing... " + (setq *sbar* (Spinbar *sbar*)) + "\t" + ) + ) + ) + ) + (setq spinflag (> (length tableobjlst) 25)) + (foreach x tableobjlst + (StripTable x formats) + (if spinflag + (princ (strcat "\rProcessing... " + (setq *sbar* (Spinbar *sbar*)) + "\t" + ) + ) + ) + ) + ) + ) + (if lockedcellflag ;_ this var is created in StripTable + (princ "\nSome table cells are locked. ") + ) + ;; calculate count + (+ (length mtextobjlst) + (length mldrobjlst) + (length dimobjlst) + (length mattobjlst) + (length tableobjlst) + ) +) ;;; End StripMtext +;; +(princ + (strcat "\nStripMtext v" *smt-smtver* " by Steve Doman and Joe Burke") +) +(princ "\nStart routine by typing \"STRIPMTEXT\" or \"SMT\" for short.") +(princ) + diff --git a/downloaded/XClipM.lsp b/downloaded/XClipM.lsp new file mode 100644 index 0000000..5b62dc1 --- /dev/null +++ b/downloaded/XClipM.lsp @@ -0,0 +1,105 @@ +; XClipM.lsp allows user to select supported objects to Clip using multiple boundaries +; Current supported objects are: +; Block Insert, External Reference, Image, DGN, DWF, PDF +; Creating a donut hole clip is not supported +; written by: Paul Li - 12/02/2010 +; updated on 3/19/2014 to support multiple objects to clip +; Note: circle shaped pline boundaries are not supported +(princ"\nLoading XclipM...")(princ) +(defun c:xclipm + (/ cmdecho count count1 emax emax1 en ChkClpBnd menuecho obxr obdxr obdxrtype obxrcopy ss ss1 xclipm_err xclipm_olderr) ; declare locally + (defun xclipm_err (msg) ; define own error function + (if (not (member msg '("console break" "Function cancelled" "quit / exit abort" ""))) ; if function not cancelled by user + (princ (strcat "\nError: " msg)) ; then show error message + ) ; if + (setvar "cmdecho" cmdecho) ; restore command echo + (setvar "menuecho" menuecho) + (princ) + ) ; defun +;end error function + (defun ChkClpBnd (ename / Data Dict tempDict) + ; Check if object has existing clipping boundry + (if + (and + (setq Data (entget ename)) + (setq Dict (cdr (assoc 360 Data))) + (setq tempDict (dictsearch Dict "ACAD_FILTER")) + (setq tempDict (dictsearch (cdr (assoc -1 tempDict)) "SPATIAL")) + ) + (cons '(0 . "SPATIAL_FILTER") (member (assoc 100 tempDict) tempDict)) ; return object if existing clipping boundary found + ) + ) ; ChkClpBnd + (setq xclipm_olderr *error* ; Save error routine + *error* xclipm_err ; Substitute ours + ) + (setq cmdecho (getvar"cmdecho")) ; save command echos + (setq menuecho (getvar"menuecho")) + (setvar"cmdecho"0)(setvar"menuecho"0) ; turn off command echos + (princ "\nSelect Block, DGN, DWF, Image, PDF or Xref to Clip:") + (setq ss1 (ssget '((-4 . "")))) + (if ss1 + (progn + (princ"\nSelect Closed Boundaries to Use for Clipping:") + (setq ss (ssget (list '(-4 . "")))) + (if ss + (progn + (setq count1 0) ; initialize counter + (setq emax1 (sslength ss1)) ; get length of ss1 + (while (< count1 emax1) ; while there are still entities in ss1 + (setq obxr (ssname ss1 count1)) ; get entity's name + (redraw obxr 3) ; highlite selected object + (setq obdxr (entget obxr)) ; retrieve objectives data + (setq obdxrtype (cdr(assoc 0 obdxr))) ; retrieve object type + (princ (strcat "\n" obdxrtype " Selected for Clipping...")) + (setq count 0) ; initialize counter + (setq emax (sslength ss)) ; get length of ss + (while (< count emax) ; while there are still entities in ss + (setq en (ssname ss count)) ; get entity's name + (cond + ((= obdxrtype "INSERT") ; if block insert or xref + (command"_.COPY" obxr "" "0,0,0" "0,0,0") ; make copy of object to clip + (setq obxrcopy (entlast)) + (if (ChkClpBnd obxrcopy)(command"_.XCLIP" obxrcopy "" "_D")) ; check if there's a clipping boundary & delete + (command"_.XCLIP" obxrcopy "" "_New" "_S" en) ; clip + ) + ((= obdxrtype "IMAGE") ; if image + (command"_.COPY" obxr "" "0,0,0" "0,0,0") + (setq obxrcopy (entlast)) + (command"_.IMAGECLIP" obxrcopy "_D") + (command"_.IMAGECLIP" obxrcopy "_New" "_S" en) + ) + ((= obdxrtype "DGNUNDERLAY") ; if dgn + (command"_.COPY" obxr "" "0,0,0" "0,0,0") + (setq obxrcopy (entlast)) + (command"_.DGNCLIP" obxrcopy "_D") + (command"_.DGNCLIP" obxrcopy "_New" "_S" en) + ) + ((= obdxrtype "DWFUNDERLAY") ; if dwf + (command"_.COPY" obxr "" "0,0,0" "0,0,0") + (setq obxrcopy (entlast)) + (command"_.DWFCLIP" obxrcopy "_D") + (command"_.DWFCLIP" obxrcopy "_New" "_S" en) + ) + ((= obdxrtype "PDFUNDERLAY") ; if pdf + (command"_.COPY" obxr "" "0,0,0" "0,0,0") + (setq obxrcopy (entlast)) + (command"_.PDFCLIP" obxrcopy "_D") + (command"_.PDFCLIP" obxrcopy "_New" "_S" en) + ) + ) ; cond + (setq count (1+ count)) ; advance to next boundary object + ) ; while + (princ (strcat "\n" obdxrtype " Clipped Successfully to Selected Boundaries.")) + (command"_.ERASE" obxr "") ; erase original object + (setq count1 (1+ count1)) ; advance to next boundary object + ) ; while + ) ; progn + (princ"\nNo Supported Closed Boundaries Selected.") + ) ; if + ) ; progn + (princ"\nNo Supported Objects Selected for Clipping.") + ) ; if ss1 + (if xclipm_olderr (setq *error* xclipm_olderr)) ; Restore old *error* handler + (setvar"cmdecho"cmdecho)(setvar"menuecho"menuecho)(princ) ; restore command echos +) ; defun xclipm +(princ"... Command loaded.")(princ) \ No newline at end of file diff --git a/downloaded/cad-corner.com/90lsp.zip b/downloaded/cad-corner.com/90lsp.zip new file mode 100644 index 0000000..3458864 Binary files /dev/null and b/downloaded/cad-corner.com/90lsp.zip differ diff --git a/downloaded/cad-corner.com/Best Of Lisp.rar b/downloaded/cad-corner.com/Best Of Lisp.rar new file mode 100644 index 0000000..53dd248 Binary files /dev/null and b/downloaded/cad-corner.com/Best Of Lisp.rar differ diff --git a/downloaded/cad-corner.com/DetailBook.zip b/downloaded/cad-corner.com/DetailBook.zip new file mode 100644 index 0000000..14eced4 Binary files /dev/null and b/downloaded/cad-corner.com/DetailBook.zip differ diff --git a/downloaded/cad-corner.com/Power.rar b/downloaded/cad-corner.com/Power.rar new file mode 100644 index 0000000..005af3d Binary files /dev/null and b/downloaded/cad-corner.com/Power.rar differ diff --git a/downloaded/cad-corner.com/archcalc.zip b/downloaded/cad-corner.com/archcalc.zip new file mode 100644 index 0000000..22a9a73 Binary files /dev/null and b/downloaded/cad-corner.com/archcalc.zip differ diff --git a/downloaded/cad-corner.com/autopat.zip b/downloaded/cad-corner.com/autopat.zip new file mode 100644 index 0000000..d42a55d Binary files /dev/null and b/downloaded/cad-corner.com/autopat.zip differ diff --git a/downloaded/cad-corner.com/bylaybk.zip b/downloaded/cad-corner.com/bylaybk.zip new file mode 100644 index 0000000..efb484a Binary files /dev/null and b/downloaded/cad-corner.com/bylaybk.zip differ diff --git a/downloaded/cad-corner.com/calc.zip b/downloaded/cad-corner.com/calc.zip new file mode 100644 index 0000000..07fd257 Binary files /dev/null and b/downloaded/cad-corner.com/calc.zip differ diff --git a/downloaded/cad-corner.com/clock.zip b/downloaded/cad-corner.com/clock.zip new file mode 100644 index 0000000..22bae57 Binary files /dev/null and b/downloaded/cad-corner.com/clock.zip differ diff --git a/downloaded/cad-corner.com/flat.lsp b/downloaded/cad-corner.com/flat.lsp new file mode 100644 index 0000000..cdc7fb8 --- /dev/null +++ b/downloaded/cad-corner.com/flat.lsp @@ -0,0 +1,32 @@ +; Flatten a 3D drawing +; Written by Eduard +; This command will set all elevations and points to zero, efectively flattening any 3D drawing. +; +(defun c:flat (/ total-nabor) + (vl-load-com) + (if + (setq total-nabor (ssget "x" '((410 . "model")))) + (progn + (setq total-nabor + (mapcar 'vlax-ename->vla-object + (mapcar 'cadr + (ssnamex total-nabor) + + ) ;_ end of mapcar + ) ;_ end of mapcar + ) ;_ end of setq + (foreach i '(1e99 -1e99) + (mapcar (function (lambda (x) + (vla-move x + (vlax-3d-point (list 0 0 0)) + (vlax-3d-point (list 0 0 i)) + ) ;_ end of vla-move + ) ;_ end of lambda + ) ;_ end of function + total-nabor + ) ;_ end of mapcar + ) ;_ end of foreach + ) ;_ end of progn + ) ;_ end of if + (princ) +) ;_ end of defun \ No newline at end of file diff --git a/downloaded/cad-corner.com/grabbag.zip b/downloaded/cad-corner.com/grabbag.zip new file mode 100644 index 0000000..0462fc6 Binary files /dev/null and b/downloaded/cad-corner.com/grabbag.zip differ diff --git a/downloaded/cad-corner.com/library.zip b/downloaded/cad-corner.com/library.zip new file mode 100644 index 0000000..d6e74d1 Binary files /dev/null and b/downloaded/cad-corner.com/library.zip differ diff --git a/downloaded/cad-corner.com/mlayer.zip b/downloaded/cad-corner.com/mlayer.zip new file mode 100644 index 0000000..7d5d027 Binary files /dev/null and b/downloaded/cad-corner.com/mlayer.zip differ diff --git a/downloaded/cad-corner.com/protxlsp.zip b/downloaded/cad-corner.com/protxlsp.zip new file mode 100644 index 0000000..e5c9662 Binary files /dev/null and b/downloaded/cad-corner.com/protxlsp.zip differ diff --git a/downloaded/mtext to mleader.lsp b/downloaded/mtext to mleader.lsp new file mode 100644 index 0000000..6b31877 --- /dev/null +++ b/downloaded/mtext to mleader.lsp @@ -0,0 +1,52 @@ + +;;; By RonJon +;;; Found at http://www.cadtutor.net/forum/showthread.php?41822-changing-text-mtext-to-multileaders... +(defun c:am (/ newleader pt1 pt2 ss txt x w rjp-getbbwdth) + (vl-load-com) + (defun rjp-getbbwdth (obj / out ll ur) + (vla-getboundingbox obj 'll 'ur) + (setq out (mapcar 'vlax-safearray->list (list ll ur))) + (distance (car out) (list (caadr out) (cadar out))) + ) + (if (setq ss (ssget '((0 . "*TEXT")))) + (progn (setq txt (apply + 'strcat + (mapcar + 'cdr + (vl-sort + (mapcar '(lambda (x) + (cons (vlax-get x 'insertionpoint) + (strcat (vlax-get x 'textstring) " ") + ) + ) + (setq + ss (mapcar + 'vlax-ename->vla-object + (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) + ) + ) + ) + (function (lambda (y1 y2) (< (cadr (car y2)) (cadr (car y1)))) + ) + ) + ) + ) + w (car (vl-sort (mapcar 'rjp-getbbwdth ss) '>)) + txt (apply 'strcat + (mapcar 'chr (reverse (cdr (reverse (vl-string->list txt))))) + ) + ) + (mapcar 'vla-delete ss) + ) + ) + (if (and (setq pt1 (getpoint "\nSpecify leader arrowhead location: ")) + (setq pt2 (getpoint pt1 "\nSpecify landing location: ")) + ) + (progn (command "._MLEADER" pt1 pt2 "") + (setq newleader (vlax-ename->vla-object (entlast))) + (vla-put-textstring newleader txt) + (vla-put-textwidth newleader w) + ) + ) + (princ) +) \ No newline at end of file diff --git a/downloaded/tlen.lsp b/downloaded/tlen.lsp new file mode 100644 index 0000000..8f0f1ba --- /dev/null +++ b/downloaded/tlen.lsp @@ -0,0 +1,32 @@ +;| + +TLEN.LSP - Total LENgth of selected objects +(c) 1998 Tee Square Graphics + +|; + +(defun C:TLEN (/ ss tl n ent itm obj l) + (setq ss (ssget) + tl 0 + n (1- (sslength ss))) + (while (>= n 0) + (setq ent (entget (setq itm (ssname ss n))) + obj (cdr (assoc 0 ent)) + l (cond + ((= obj "LINE") + (distance (cdr (assoc 10 ent))(cdr (assoc 11 ent)))) + ((= obj "ARC") + (* (cdr (assoc 40 ent)) + (if (minusp (setq l (- (cdr (assoc 51 ent)) + (cdr (assoc 50 ent))))) + (+ pi pi l) l))) + ((or (= obj "CIRCLE")(= obj "SPLINE")(= obj "POLYLINE") + (= obj "LWPOLYLINE")(= obj "ELLIPSE")) + (command "_.area" "_o" itm) + (getvar "perimeter")) + (T 0)) + tl (+ tl l) + n (1- n))) + (alert (strcat "Total length of selected objects is " (rtos tl))) + (princ) +) diff --git a/dxf examples/polyline.txt b/dxf examples/polyline.txt new file mode 100644 index 0000000..19cff81 --- /dev/null +++ b/dxf examples/polyline.txt @@ -0,0 +1,47 @@ +( + (-1 . ) APP: entity name (changes each time a drawing is opened) + (0 . "LWPOLYLINE") Entity type + (330 . ) Soft-pointer ID/handle to owner dictionary (optional) + (5 . "27C") Handle + (100 . "AcDbEntity") Subclass marker (AcDbEntity) + (67 . 0) Absent or zero indicates entity is in model space. 1 indicates entity is in paper space (optional). + (410 . "Model") APP: layout tab name + (8 . "0") Layer + (100 . "AcDbPolyline") Subclass marker (AcDb2dPolyline or AcDb3dPolyline) + (90 . 3) + (70 . 0) Polyline flag (bit-coded; default = 0): + (43 . 0.0) + (38 . 0.0) + (39 . 0.0) + (10 1803.05 2175.82) + (40 . 0.0) Default start width (optional; default = 0) + (41 . 0.0) Default end width (optional; default = 0) + (42 . 0.0) + (91 . 0) + (10 3137.32 1449.0) + (40 . 0.0) Default start width (optional; default = 0) + (41 . 0.0) Default end width (optional; default = 0) + (42 . 0.0) + (91 . 0) + (10 3790.2 665.109) + (40 . 0.0) Default start width (optional; default = 0) + (41 . 0.0) Default end width (optional; default = 0) + (42 . 0.0) + (91 . 0) + (210 0.0 0.0 1.0) +) + +( + (-1 . ) + (0 . "LINE") + (330 . ) + (5 . "28B") + (100 . "AcDbEntity") + (67 . 0) + (410 . "Model") + (8 . "0") + (100 . "AcDbLine") + (10 4421.78 702.849 0.0) + (11 4006.62 985.206 0.0) + (210 0.0 0.0 1.0) +) \ No newline at end of file diff --git a/dxf examples/rotated dimension b/dxf examples/rotated dimension new file mode 100644 index 0000000..cb417d7 --- /dev/null +++ b/dxf examples/rotated dimension @@ -0,0 +1,39 @@ +( + (-1 . ) + (0 . "DIMENSION") + (330 . ) + (5 . "3B77") + (100 . "AcDbEntity") + (67 . 0) + (410 . "Model") + (8 . "A-ANNO-DIMS") + (100 . "AcDbDimension") + (280 . 0) + (2 . "*D58") + (10 1268.78 538.065 0.0) + (11 1262.4 435.815 0.0) + (12 0.0 0.0 0.0) + (70 . 32) + (1 . "11 {\\H0.7x;\\S7/8;}\" TJI 360 AT 16\" OC") + (71 . 5) + (72 . 1) + (41 . 1.0) + (42 . 204.5) + (73 . 0) + (74 . 0) + (75 . 0) + (52 . 0.0) + (53 . 0.0) + (54 . 0.0) + (51 . 0.0) + (210 0.0 0.0 1.0) + (3 . "Arrows") + (100 . "AcDbAlignedDimension") + (13 1224.26 333.565 0.0) + (14 1256.76 538.065 0.0) + (15 0.0 0.0 0.0) + (16 0.0 0.0 0.0) + (40 . 0.0) + (50 . 1.5708) + (100 . "AcDbRotatedDimension") +) \ No newline at end of file diff --git a/dxfval.lsp b/dxfval.lsp new file mode 100644 index 0000000..d437e83 --- /dev/null +++ b/dxfval.lsp @@ -0,0 +1,109 @@ +;; dxfval.lsp +;; +;; A simple lisp, which prints the dxf properties of elements to the console +;; +;; Created by Peter Gyetvai +;; gyetpet@gmail.com +;; gyetvai-peter.hu + +(defun C:dxfval (/ i imax il j jmax jl x ss currElem code groupCode en2 enlist2 ) + ;variables: + (setq i 0);counter to zero + (setq imax 1);while variable + + (setq j 0);counter to zero + (setq jmax 1);while variable + + ;; (vl-load-com) + (graphscr) + (initget 1 "Pick All") + (setq x (getkword "Pick elements or all? [Pick/All]")) + (if (= x "Pick") + (progn + (prompt "\nSelect elements: [All]") + (setq ss (ssget));asks for selection + ) + (setq ss (ssget "_X")) + ) + + (setq il (sslength ss));length of selection + (prompt "\nDxf group code: (leave empty for all) ") + (setq groupCode (getint)) + (print groupCode) + + (while imax + (print ) + (print ) + (princ "Checking element ") + (princ (1+ i)) + (princ "/") + (princ il) + + (setq currElem (entget (ssname ss i) )) + + (if groupCode + (progn + (print (cdr (assoc groupCode currElem))) + ) + (progn + (setq jl (length currElem)) + + (while jmax + (print (nth j currElem)) + + + + (setq j (1+ j));increments i + (if (= j jl) (setq jmax nil));finish function if i equals il + ) + + (setq j 0);counter to zero + (setq jmax 1);while variable + + + (setq en2(entnext (ssname ss i))) ;- Get the next sub-entity + + (if en2 + (progn + (print ) + (princ "Sub entities: ") + (setq enlist2(entget en2)) ;- Get the DXF group codes + + (while (/= (cdr(assoc 0 enlist2)) "SEQEND") ;- Start the while loop and keep ;- looping until SEQEND is found. + + (princ "\n ") ;-Print a new line + + (princ enlist2) ;- Print the attribute DXF group codes + + (setq en2(entnext en2)) + (setq enlist2(entget en2)) + (print "enlist2 ok") + ) + + ) + (progn + (print ) + (princ "No sub entities") + ) + ) + ) + ) + + + + (if (not (or (= il 1)(= (1+ i) il))) + (progn + (prompt "\nPress any key to continue to the next element: ") + (setq code (grread)) + ) + ) + + + ;while specific: + (setq i (1+ i));increments i + (if (= i il) (setq imax nil));finish function if i equals il + ) + + (setq ss nil) + (princ) +) diff --git a/imagePaths.lsp b/imagePaths.lsp new file mode 100644 index 0000000..3904308 --- /dev/null +++ b/imagePaths.lsp @@ -0,0 +1,29 @@ +(defun c:imagePaths (Doc / LayoutCol EndList) +; Returns a list of list of all the Xrefs and Images with their paths withina drawing. + + (vl-load-com) + (if (not Doc) + (setq Doc (vla-get-ActiveDocument (vlax-get-Acad-Object))) + ) + (setq LayoutCol (vla-get-Layouts Doc)) + (vlax-for i LayoutCol + (vlax-for Obj (vla-get-Block i) + (cond + ((= (vla-get-ObjectName Obj) "AcDbRasterImage") + (if (not (assoc (vla-get-Name Obj) EndList)) + (setq EndList (cons (cons (vla-get-Name Obj) (vla-get-ImageFile Obj)) + EndList)) + ) + ) + ((and (= (vla-get-ObjectName Obj) "AcDbBlockReference") + (vlax-property-available-p Obj 'Path)) + (if (not (assoc (vla-get-Name Obj) EndList)) + (setq EndList (cons (cons (vla-get-Name Obj) (vla-get-Path Obj)) + EndList)) + ) + ) + ) + ) + ) + EndList +) \ No newline at end of file diff --git a/layerFromColor.lsp b/layerFromColor.lsp new file mode 100644 index 0000000..c150301 --- /dev/null +++ b/layerFromColor.lsp @@ -0,0 +1,71 @@ +(defun C:LFC (/ i imax il ss currElem color colorNum allColors newLayer currLayer newElem) + (graphscr) + + ;variables: + (setq i 0);counter to zero + (setq imax 1);while variable + + (prompt "\nselect entities to change layer (all): ") + (setq ss (ssget));asks for selection + (setq il (sslength ss));length of selection + (setq allColors nil) + (while imax + (print i) + (setq currElem (entget (ssname ss i) )) + (setq color (assoc 62 currElem)) + (setq colorNum (cdr color)) + (print colorNum) + + (if (and (not (= colorNum 0)) colorNum) + (progn + (if (not (type allColors))( setq allColors (list colorNum))) + (if (not (member colorNum allColors)) (setq allColors (append allColors (list colorNum)))) + ) + ) + + ;while specific: + (setq i (1+ i));increments i + (if (= i il) (setq imax nil));finish function if i equals il + ) + + + (setq i 0);counter to zero + (setq imax 1);while variable + + (while imax + (print i) + (setq color (nth i allColors)) + (command "._layer" "_M" color "") + ;while specific: + (setq i (1+ i));increments i + (if (= i (length allColors)) (setq imax nil));finish function if i equals il + ) + + (setq i 0);counter to zero + (setq imax 1);while variable + + (while imax + (print i) + (setq currElem (entget (ssname ss i) )) + (setq color (assoc 62 currElem)) + (setq colorNum (cdr color)) + + (if (and (not (= colorNum 0)) colorNum) + (progn + + + (setq currLayer (assoc 8 currElem)) + (setq newLayer (cons 8 (itoa colorNum))) + (print newLayer) + (setq newElem(subst newLayer currLayer currElem)) + (entmod newElem) + ) + ) + ;while specific: + (setq i (1+ i));increments i + (if (= i il) (setq imax nil));finish function if i equals il + ) + + (terpri) + (setq ss nil) +) diff --git a/mleaderHeight.lsp b/mleaderHeight.lsp new file mode 100644 index 0000000..bc6511d --- /dev/null +++ b/mleaderHeight.lsp @@ -0,0 +1,18 @@ +(defun c:foo (/ e elev ss) + (if + (and (setq elev (getdist "\nEnter elevation: ")) (setq ss (ssget ":L" '((0 . "MULTILEADER"))))) + (while (setq e (ssname ss 0)) + (entmod (mapcar '(lambda (x) + (if (member (car x) '(10 12 110)) + (list (car x) (cadr x) (caddr x) elev) + x + ) + ) + (entget e '("*")) + ) + ) + (ssdel e ss) + ) + ) + (princ) +) \ No newline at end of file diff --git a/pline-3d-2d.lsp b/pline-3d-2d.lsp new file mode 100644 index 0000000..454f265 --- /dev/null +++ b/pline-3d-2d.lsp @@ -0,0 +1,136 @@ +;;CADALYST 09/03 AutoLISP Solutions +;;; PLINE-3D-2D.LSP - a program to convert +;;; 3D polylines to 2D +;;; Program by Tony Hotchkiss + +(defun pline-3d-2d () + (vl-load-com) + (setq *thisdrawing* (vla-get-activedocument + (vlax-get-acad-object) + ) ;_ end of vla-get-activedocument + *modelspace* (vla-get-ModelSpace *thisdrawing*) + ) ;_ end of setq + (setq 3d-pl-list + (get-3D-pline) + ) ;_ end of setq + (if 3d-pl-list + (progn + (setq vert-array-list (make-list 3d-pl-list)) + (setq n (- 1)) + (repeat (length vert-array-list) + (setq vert-array (nth (setq n (1+ n)) vert-array-list)) + (setq lyr (vlax-get-property (nth n 3d-pl-list) 'Layer)) + (setq obj (vla-AddPolyline *modelspace* vert-array)) + (vlax-put-property obj 'Layer lyr) + ) ;_ end of repeat + (foreach obj 3d-pl-list (vla-delete obj)) + ) ;_ end of progn + ) ;_ end of if +) ;_ end of pline-3d-2d + +(defun get-3D-pline () + (setq pl3dobj-list nil + obj nil + 3d "AcDb3dPolyline" + ) ;_ end of setq + (setq selsets (vla-get-selectionsets *thisdrawing*)) + (setq ss1 (vlax-make-variant "ss1")) + (if (= (vla-get-count selsets) 0) + (setq ssobj (vla-add selsets ss1)) + ) ;_ end of if + (vla-clear ssobj) + (setq Filterdata (vlax-make-variant "POLYLINE")) + (setq no-ent 1) + (while no-ent + (vla-Selectonscreen ssobj) + (if (> (vla-get-count ssobj) 0) + (progn + (setq no-ent nil) + (setq i (- 1)) + (repeat (vla-get-count ssobj) + (setq + obj (vla-item ssobj + (vlax-make-variant (setq i (1+ i))) + ) ;_ end of vla-item + ) ;_ end of setq + (cond + ((= (vlax-get-property obj "ObjectName") 3d) + (setq pl3dobj-list + (append pl3dobj-list (list obj)) + ) ;_ end of setq + ) + ) ;_ end-of cond + ) ;_ end of repeat + ) ;_ end of progn + (prompt "\nNo entities selected, try again.") + ) ;_ end of if + (if (and (= nil no-ent) (= nil pl3dobj-list)) + (progn + (setq no-ent 1) + (prompt "\nNo 3D-polylines selected.") + (quit) + ) ;_ end of progn + ) ;_ end of if + ) ;_ end of while + (vla-delete (vla-item selsets 0)) + pl3dobj-list +) ;_ end of get-3D-pline + + +(defun get-3D-pline-old () + (setq no-ent 1) + (setq filter '((-4 . "") + ) + ) ;_ end of setq + (while no-ent + (setq ss (ssget filter) + k (- 1) + pl3dobj-list nil + obj nil + 3d "AcDb3dPolyline" + ) ;_ end-of setq + (if ss + (progn + (setq no-ent nil) + (repeat (sslength ss) + (setq ent (ssname ss (setq k (1+ k))) + obj (vlax-ename->vla-object ent) + ) ;_ end-of setq + (cond + ((= (vlax-get-property obj "ObjectName") 3d) + (setq pl3dobj-list + (append pl3dobj-list (list obj)) + ) ;_ end of setq + ) + ) ;_ end-of cond + ) ;_ end-of repeat + ) ;_ end-of progn + (prompt "\nNo 3D-polylines selected, try again.") + ) ;_ end-of if + ) ;_ end-of while + pl3dobj-list +) ;_ end of get-3D-pline-old + +(defun make-list (p-list) + (setq i (- 1) + vlist nil + calist nil + ) ;_ end of setq + (repeat (length p-list) + (setq obj (nth (setq i (1+ i)) p-list) + coords (vlax-get-property obj "coordinates") + ca (vlax-variant-value coords) + ) ;_ end-of setq + (setq calist (append calist (list ca))) + ) ;_ end-of repeat +) ;_ end-of make-list + +(defun c:pl32 () + (pline-3d-2d) + (princ) +) ;_ end of pl32 + +(prompt "Enter PL32 to start: ") diff --git a/ptfix.lsp b/ptfix.lsp new file mode 100644 index 0000000..6df975f --- /dev/null +++ b/ptfix.lsp @@ -0,0 +1,142 @@ +;; ptfix.lsp +;; +;; Fix inaccurate points in AutoCAD with this lisp routine +;; Select the elements you want to modify, click the desired point and add a tolerance. +;; The points which are closer to the desired point than the tolerance will be moved to the desired point. +;; Video about how it works: https://www.youtube.com/watch?v=iiLdYgVTKkc +;; +;; Created by Peter Gyetvai +;; gyetpet@gmail.com +;; gyetvai-peter.hu +;; +;; massoc routine created by Jason Piercey: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/getting-multiple-assoc-values/td-p/852437 + +(defun massoc (key alist / x nlist) + (foreach x alist + (if (eq key (car x)) + (setq nlist (cons (cdr x) nlist)) + ) + ) + (reverse nlist) +) + +(defun C:ptfix (/ ss i il imax j jl jmax currElem currTyp currPoints currPointXY goodPoint goodPointXY tolerance currDist newPoint newElem movedPoints oldMovedPoints movedElems) + ;variables: + (setq i 0);counter to zero + (setq imax 1);while variable + (setq movedPoints 0) + (setq movedElems 0) + + (vl-load-com) + (graphscr) + (prompt "\nSelect polylines: ") + (setq ss (ssget));asks for selection + (setq il (sslength ss));length of selection + (setq goodPoint (getpoint "\nSelect desired point: ")) + (setq goodPointXY (vl-remove (last goodPoint) goodPoint)) + (setq tolerance (getdist "\nTolerance?")) + + (while imax + (print ) + (princ "Checking element ") + (princ i) + + (setq currElem (entget (ssname ss i) )) + (setq currTyp (cdr (assoc 0 currElem))) + (setq oldMovedPoints movedPoints) + + (print ) + (princ " Element type: ") + (princ currTyp) + (cond + ( + (= currTyp "LWPOLYLINE");if polyline + (progn + (setq currPoints (massoc 10 currElem)) + ;; (print currPoints) + + (setq jl (length currPoints)) + (setq j 0);counter to zero + (setq jmax 1);while variable + (while jmax + (print ) + (princ " Checking point: ") + (princ (nth j currPoints)) + + (setq currDist (distance (nth j currPoints) goodPointXY)) + (if + (and (< currDist tolerance) (/= currDist 0)) + (progn + (setq newPoint (cons 10 goodPointXY)) + (setq newElem(subst newPoint (cons 10 (nth j currPoints)) currElem)) + (setq currElem newElem) + (entmod newElem) + (princ " - Point moved to desired location") + (setq movedPoints (1+ movedPoints)) + ) + (progn + (princ " - Point is farther than tolerance") + ) + ) + + ;while specific: + (setq j (1+ j));increments i + (if (= j jl) (setq jmax nil));finish function if i equals il + ) + (if (/= oldMovedPoints movedPoints) (setq movedElems (1+ movedElems))) + ) + );polyline end + ( + (= currTyp "LINE") + (progn + (setq j 10) + (repeat 2 + (progn + (setq currPoints (cdr (assoc j currElem))) + (print ) + (princ " Checking point: ") + (princ currPoints) + (setq currPointXY (vl-remove (last currPoints) currPoints)) + (setq currDist (distance currPointXY goodPointXY)) + + (if + (and (< currDist tolerance) (/= currDist 0)) + (progn + (setq newPoint (cons j goodPoint)) + (setq newElem(subst newPoint (cons j currPoints) currElem)) + (setq currElem newElem) + (entmod newElem) + (princ " - Point moved to desired location") + (setq movedPoints (1+ movedPoints)) + ) + (progn + (princ " - Point is farther than tolerance") + ) + ) + (setq j 11) + ) + ) + (if (/= oldMovedPoints movedPoints) (setq movedElems (1+ movedElems))) + ) + ); line end + (progn + (print ) + (princ " This element is not line or polyline!") + ) + ) + + ;while specific: + (setq i (1+ i));increments i + (if (= i il) (setq imax nil));finish function if i equals il + ) + + (terpri) + (princ movedPoints) + (princ " point(s) moved to the desired location") + (terpri) + (princ movedElems) + (princ " element(s) modified") + + (setq ss nil) + (princ) +) \ No newline at end of file diff --git a/randomRotate.lsp b/randomRotate.lsp new file mode 100644 index 0000000..c1f5ea0 --- /dev/null +++ b/randomRotate.lsp @@ -0,0 +1,63 @@ +(defun C:randRot (/ ss i il imax maxDeg currElem currRotList currRot currRotDeg randomNumber newRotDeg newRot newRotList newElem) + ;variables: + (setq i 0);counter to zero + (setq imax 1);while variable + + (graphscr) + (prompt "\nselect entities to be rotated: ") + (setq ss (ssget));asks for selection + (setq il (sslength ss));length of selection + + + (setq maxDeg (getreal "\nMaximum degrees :")) + + + (while imax + (print i) + (setq currElem (entget (ssname ss i) )) + (setq currRotList (assoc 50 currElem)) + (setq currRot (cdr currRotList)) + (setq currRotDeg (rtd currRot)) + (setq randomNumber (- (fix(* (* 2 maxDeg) (rnd))) maxDeg)) + (setq newRotDeg (+ randomNumber currRotDeg)) + (setq newRot (dtr newRotDeg)) + + (setq newRotList(cons 50 newRot)) + + (setq newElem(subst newRotList currRotList currElem)) + ;; (print currElem) + ;; (print newElem) + (entmod newElem) + + + ;while specific: + (setq i (1+ i));increments i + (if (= i il) (setq imax nil));finish function if i equals il + ) + + (terpri) + (setq ss nil) +) + + +(defun rnd (/ modulus multiplier increment random) + (if (not seed) + (setq seed (getvar "DATE")) + ) + (setq modulus 65536 + multiplier 25173 + increment 13849 + seed (rem (+ (* multiplier seed) increment) modulus) + random (/ seed modulus) + ) +) + + +(defun dtr (a) + (* pi (/ a 180)) +) + + +(defun rtd (a) + (/ (* a 180) pi) +) \ No newline at end of file diff --git a/scr/acadsettings.scr b/scr/acadsettings.scr new file mode 100644 index 0000000..3e1f6f8 --- /dev/null +++ b/scr/acadsettings.scr @@ -0,0 +1,14 @@ +._taskbar +0 +._FILETABTHUMBHOVER +0 +._FILETABPREVIEW +0 +._CURSORSIZE +100 +._pickbox +6 +._PROXYNOTICE +0 +._PROXYSHOW +1 diff --git a/scr/bindAll.scr b/scr/bindAll.scr new file mode 100644 index 0000000..196cf55 --- /dev/null +++ b/scr/bindAll.scr @@ -0,0 +1,5 @@ +_.bindtype +1 +_.-xref +b +* \ No newline at end of file diff --git a/scr/reloadCirc.scr b/scr/reloadCirc.scr new file mode 100644 index 0000000..8f49d02 --- /dev/null +++ b/scr/reloadCirc.scr @@ -0,0 +1,7 @@ +-linetype +L +X-LINE +"C:\Users\gyetp\AppData\Roaming\Autodesk\AutoCAD 2018\R22.0\enu\Support\LINETYPES\AlapVonalak.lin" + + +regenall diff --git a/scr/revitDwgImportCleaner.scr b/scr/revitDwgImportCleaner.scr new file mode 100644 index 0000000..55cb1c5 --- /dev/null +++ b/scr/revitDwgImportCleaner.scr @@ -0,0 +1,16 @@ +;version 1.0 +;Run this script before importing dwg-s to Revit +;Created by Peter Gyetvai - gyetpet@gmail.com +._MODEL +._-PURGE +a +* +n +._ZOOM +e +._AUDIT +y +._-AECEXPORTTOAUTOCAD +f +2013 + diff --git a/scriptpro filelists/arago 1-27.bpl b/scriptpro filelists/arago 1-27.bpl new file mode 100644 index 0000000..1448c7c --- /dev/null +++ b/scriptpro filelists/arago 1-27.bpl @@ -0,0 +1,41 @@ +[General_Start] +Version*3 +Product*2011 +Script*C:\Users\gyetp\Documents\_Revit families\_lisp\scr\revitCleaner.scr +TimeOut*30 +RestartCount*30 +IniScript* +LogFileName* +AutoCADPath* +Sleep*0 +RunwithoutOpen*False +[General_End] +[DWGList_Start] +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg01 - NIVEAU -1.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg02 - NIVEAU 0.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg03 - NIVEAU 1.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg04 - NIVEAU 2.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg05 - TOITURE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg06 - COUPE AA.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg07 - COUPE BB.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg08 - COUPE CC.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg09 - COUPE DD.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg10 - ELÉVATION NORD-EST SUR RUE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg11 - ELÉVATION SUD-OUEST BAT A.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg12 - ELÉVATION NORD-EST BAT B.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg13 - ELÉVATION SUD-OUEST BAT B.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg14 - ELÉVATION NORD-EST BAT C.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg15 - ELÉVATION SUD-OUEST BAT C.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg16 - ELÉVATION NORD-EST BAT D.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg17 - ELÉVATION SUD-OUEST BAT D.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg18 - ELÉVATION NORD-EST BAT D ARRIERE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg19 - ELÉVATION SUD-OUEST BAT D ARRIERE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg20 - ELÉVATION NORD-EST BAT E.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg21 - ELÉVATION SUD-OUEST BAT E.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg22 - ELÉVATION NORD-EST BAT F.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg23 - ELÉVATION SUD-OUEST BAT F.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg24 - ELÉVATION NORD-EST BAT G.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg25 - ELÉVATION SUD-OUEST BAT G.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg26 - PIGNON NORD-EST 1_50.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg27 - PIGNON SUD-EST 1_50.dwg,1 +[DWGList_End] diff --git a/scriptpro filelists/arago 1-27_13_2_29_13_failed.bpl b/scriptpro filelists/arago 1-27_13_2_29_13_failed.bpl new file mode 100644 index 0000000..7efd07e --- /dev/null +++ b/scriptpro filelists/arago 1-27_13_2_29_13_failed.bpl @@ -0,0 +1,41 @@ +[General_Start] +Version*3 +Product*2011 +Script*C:\Users\gyetp\Documents\_Revit families\_lisp\scr\revitCleaner.scr +TimeOut*30 +RestartCount*30 +IniScript* +LogFileName*C:\Users\gyetp\AppData\Local\Temp\ +AutoCADPath* +Sleep*0 +RunwithoutOpen*False +[General_End] +[DWGList_Start] +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg01 - NIVEAU -1.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg02 - NIVEAU 0.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg03 - NIVEAU 1.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg04 - NIVEAU 2.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg05 - TOITURE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg06 - COUPE AA.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg07 - COUPE BB.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg08 - COUPE CC.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg09 - COUPE DD.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg10 - ELÉVATION NORD-EST SUR RUE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg11 - ELÉVATION SUD-OUEST BAT A.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg12 - ELÉVATION NORD-EST BAT B.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg13 - ELÉVATION SUD-OUEST BAT B.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg14 - ELÉVATION NORD-EST BAT C.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg15 - ELÉVATION SUD-OUEST BAT C.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg16 - ELÉVATION NORD-EST BAT D.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg17 - ELÉVATION SUD-OUEST BAT D.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg18 - ELÉVATION NORD-EST BAT D ARRIERE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg19 - ELÉVATION SUD-OUEST BAT D ARRIERE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg20 - ELÉVATION NORD-EST BAT E.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg21 - ELÉVATION SUD-OUEST BAT E.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg22 - ELÉVATION NORD-EST BAT F.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg23 - ELÉVATION SUD-OUEST BAT F.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg24 - ELÉVATION NORD-EST BAT G.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg25 - ELÉVATION SUD-OUEST BAT G.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg26 - PIGNON NORD-EST 1_50.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH --Sheet - dwg27 - PIGNON SUD-EST 1_50.dwg,1 +[DWGList_End] diff --git a/scriptpro filelists/arago 1-27_29_3_36_48_failed.bpl b/scriptpro filelists/arago 1-27_29_3_36_48_failed.bpl new file mode 100644 index 0000000..ff916e3 --- /dev/null +++ b/scriptpro filelists/arago 1-27_29_3_36_48_failed.bpl @@ -0,0 +1,41 @@ +[General_Start] +Version*3 +Product*2011 +Script*C:\Users\gyetp\Documents\_Revit families\_lisp\scr\revitCleaner.scr +TimeOut*30 +RestartCount*30 +IniScript* +LogFileName*C:\Users\gyetp\AppData\Local\Temp\ +AutoCADPath* +Sleep*0 +RunwithoutOpen*False +[General_End] +[DWGList_Start] +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 01 - NIVEAU -1.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 02 - NIVEAU 0.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 03 - NIVEAU 1.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 04 - NIVEAU 2.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 05 - TOITURE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 06 - COUPE AA.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 07 - COUPE BB.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 08 - COUPE CC.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 09 - COUPE DD.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 10 - ELÉVATION NORD-EST SUR RUE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 11 - ELÉVATION SUD-OUEST BAT A.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 12 - ELÉVATION NORD-EST BAT B.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 13 - ELÉVATION SUD-OUEST BAT B.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 14 - ELÉVATION NORD-EST BAT C.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 15 - ELÉVATION SUD-OUEST BAT C.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 16 - ELÉVATION NORD-EST BAT D.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 17 - ELÉVATION SUD-OUEST BAT D.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 18 - ELÉVATION NORD-EST BAT D ARRIERE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 19 - ELÉVATION SUD-OUEST BAT D ARRIERE.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 20 - ELÉVATION NORD-EST BAT E.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 21 - ELÉVATION SUD-OUEST BAT E.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 22 - ELÉVATION NORD-EST BAT F.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 23 - ELÉVATION SUD-OUEST BAT F.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 24 - ELÉVATION NORD-EST BAT G.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 25 - ELÉVATION SUD-OUEST BAT G.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 26 - PIGNON NORD-EST 1_50.dwg,1 +C:\Users\gyetp\Documents\__dwgout\EX_ARAGO-ARCH-26-06-2018-Sheet - 27 - PIGNON SUD-EST 1_50.dwg,1 +[DWGList_End]