LISP
How to use theseEdit
- Copy a chosen routine to a text file and name it arbitrarily with a
.lspfile extension. - In AutoCAD type
APPLOADand choose the.lspfile. - Execute the command using the command text in the routine's header on here.
Sum numbers in text Command: ADDEdit
(defun dxf (code elist)
(cdr (assoc code elist))
)
(defun C:Add ( / ed en et text1 a b c d total )
(setq en (entsel "\nSelect text to update to total")
ed (entget (car en))
et (dxf 0 ed)
)
(if (= et "TEXT")
(progn
(setq text1 (cdr (assoc 1 (setq e ed))))
(setq a (* 1.1 (atof text1)))
(setq b (rtos a))
(setq c (atoi b))
(setq d (itoa c))
(setq total (atof d))
(entmod
(setq ed (subst (cons 1 (rtos total 2)) (assoc 1 ed) ed))
)
)
)
(princ)
);defun
(PRINC "\n ADD.LSP v0.10 Copyright (c) 2003 by D. Lowe dcldesign")(princ)(defun dxf (code elist)
(cdr (assoc code elist))
)
(defun C:inflation ( / ed en et text1 a b c d total rate)
(setq rate (getreal "Enter multiplying factor (eg 1.1 = 10%): "))
(setq en (entsel "\nSelect text to update to total")
ed (entget (car en))
et (dxf 0 ed)
)
(if (= et "TEXT")
(progn
(setq text1 (cdr (assoc 1 (setq e ed))))
(setq a (* rate (atof text1)))
(setq b (rtos a))
(setq c (atoi b))
(setq d (itoa c))
(setq total (atof d))
(entmod
(setq ed (subst (cons 1 (rtos total 2)) (assoc 1 ed) ed))
)
)
)
(princ)
);defun
(PRINC "\n inflation.LSP v0.20 Copyright (c) 2003 by D. Lowe dcldesign")(princ);******************************************************************
;Add.lsp 6/17/96
;v1.01 7/2/96 fixed to use local variables
;v1.02 1/15/97 Cleaned up commented out code. Added more instructions.
;*****************************************************************
;Add string lisp routine will take a selection of text and add the
;numbers together.
;Use:
;Select some stuff. All non-text items are ignored. Any numbers in
;the selected text will be added together. Select a text item to be
;updated. The selected text item will be replaced with the result of
;the addition.
;
;Note that the units command will affect the format of the results.
;If you get a number will a bunch of trailing 0's then change units
;to fix the problem.
;
; * Copyright 1996 by J. Marsden DeLapp *
;*************************************************************
;dxf function takes an integer dxf code & ent data list and
;returns the value for that dxf code.
(defun dxf (code elist)
(cdr (assoc code elist))
);defun
;*************************************************************
;ss1 - selection set
;n - number of items in selection set (counter)
;total - total of float numbers in selection set
;e -
;
(defun C:Add ( / ed en et i n ss1 text1 total )
(setq ss1 (ssget '((0 . "TEXT")))) ; Select objects, only text
(if ss1 ; If any objects selected
(progn
(setq i 0
total 0
n (sslength ss1)); reset tot, set n to number of items
(while (< i n) ; For each selected object...
(setq text1 (cdr (assoc 1 (setq e (entget (ssname ss1 i))))))
(setq total (+ total (atof text1)))
(setq i (1+ i)) ; increment counter
);while
);progn
);if
(princ "Total ")
(princ total)
(terpri)
(setq en (entsel "\nSelect text to update to total")
ed (entget (car en))
et (dxf 0 ed)
)
(if (= et "TEXT") ; verify text was selected
;(rtos total 2) returns total formated as a string in decimal format
;substitute the new text for the old text...
(progn
(entmod
(setq ed (subst (cons 1 (rtos total 2)) (assoc 1 ed) ed))
);entmod
)
);if
(princ)
);defun
(PRINC "\n ADD.LSP v1.02 Copyright (c) 1997 by J. Marsden DeLapp")(princ)
Remove CR from Mtext Command: RREdit
(vl-load-com)
;; Remove Returns
(defun c:rr ( / c_doc ss)
(prompt "\nSelect MText entities to strip c/r : ")
(setq c_doc (vla-get-activedocument (vlax-get-acad-object))
ss (ssget "_:L" '((0 . "MTEXT")))
);end_setq
(cond (ss
(vlax-for obj (vla-get-activeselectionset c_doc)
(while (wcmatch (vla-get-textstring obj) "*\\P*")
(vla-put-textstring obj (vl-string-subst " " "\\P" (vla-get-textstring obj)))
);end_while
);end_for
)
( (alert "Nothing Selected"))
);end_cond
(princ)
);end_defun
Remove CR from Table Command: RRTEdit
(vl-load-com)
;; Remove Returns
(defun c:rrt ( / c_doc ss)
(prompt "\nSelect MText entities to strip c/r : ")
(setq c_doc (vla-get-activedocument (vlax-get-acad-object))
ss (ssget "_:L" '((0 . "TABLE")))
);end_setq
(cond (ss
(vlax-for obj (vla-get-activeselectionset c_doc)
(while (wcmatch (vla-get-textstring obj) "*\\P*")
(vla-put-textstring obj (vl-string-subst " " "\\P" (vla-get-textstring obj)))
);end_while
);end_for
)
( (alert "Nothing Selected"))
);end_cond
(princ)
);end_defun
Don't know what this is :-(Edit
(defun c:reline ( / ) (defun relinererror (s) (print s) (setvar "cmdecho" 0) (command "._undo" "end") (setvar "clayer" relineclayer) (setvar "osmode" relineosmode) (setvar "cmdecho" 1) (setq *error* olderr) (princ) ) (defun dxf (1code 1ent) (cdr (assoc 1code 1ent))) (defun makeseg (x1 x2 y1 y2 z1 z2 / ) (setq pt1 (list x1 y1 z1)) (setq pt2 (list x2 y2 z2)) (entmake (list (cons 0 "LINE") (cons 6 "CONTINUOUS") (cons 8 "0") (cons 10 pt1) (cons 11 pt2) (cons 62 7) ) ) ) (defun fixlines ( / ) (if (setq ss (ssget "_X" '((0 . "LINE")))) (progn (setq 6cntr (sslength ss)) (while (> 6cntr 0) (setq 6cntr (1- 6cntr)) (setq 6ent (entget (ssname ss 6cntr))) (if (= (dxf 6 6ent) "DASHED") (progn (setq startx (cadr (assoc 10 6ent))) (setq starty (caddr (assoc 10 6ent))) (setq startz (cadddr (assoc 10 6ent))) (setq endx (cadr (assoc 11 6ent))) (setq endy (caddr (assoc 11 6ent))) (setq endz (cadddr (assoc 11 6ent))) (setq deltax (- endx startx)) (setq deltay (- endy starty)) (setq deltaz (- endz startz)) (setq llength (sqrt (+ (* deltax deltax) (* deltay deltay)))) (setq llength (sqrt (+ (* llength llength) (* deltaz deltaz)))) (setq segments (/ llength dashlength)) (setq segments (fix segments)) (if (= (rem segments 3) 0) (setq segments (+ 2 segments)) (if (= (rem segments 3) 1) (setq segments (+ 1 segments)) ) ) (if (> segments 3) (progn (setq e0 (ssname ss 6cntr)) (entdel e0) (if (equal deltax 0.0 0.000001) (setq xinterval 0.0) (setq xinterval (/ deltax segments)) ) (if (equal deltay 0.0 0.000001) (setq yinterval 0.0) (setq yinterval (/ deltay segments)) ) (if (equal deltaz 0.0 0.000001) (setq zinterval 0.0) (setq zinterval (/ deltaz segments)) ) (setq cntr2 0) (while (< cntr2 segments) (progn (if (= cntr2 0) (progn (setq x1 startx) (setq x2 (+ x1 (* 2 xinterval))) (setq y1 starty) (setq y2 (+ y1 (* 2 yinterval))) (setq z1 startz) (setq z2 (+ z1 (* 2 zinterval))) (makeseg x1 x2 y1 y2 z1 z2) ) (progn (setq x1 (+ x2 xinterval)) (setq x2 (+ x1 (* 2 xinterval))) (setq y1 (+ y2 yinterval)) (setq y2 (+ y1 (* 2 yinterval))) (setq z1 (+ z2 zinterval)) (setq z2 (+ z1 (* 2 zinterval))) (makeseg x1 x2 y1 y2 z1 z2) ) ) (setq cntr2 (+ 3 cntr2)) ) ) ) ) ) ) ) ) ) ) (setvar "cmdecho" 0) (command "._undo" "begin") (setq olderr *error* *error* encorelineerror) (setq dashlength 1.0) (setq relineosmode (getvar "osmode")) (setq relineclayer (getvar "clayer")) (fixlines) (setvar "cmdecho" 0) (setvar "clayer" relineclayer) (setvar "osmode" relineosmode) (command "._undo" "end") (setvar "cmdecho" 1) (setq *error* olderr) (princ) )
Draw wobbly lines to simulate hand drawn Command: WPLEdit
This breaks up lines into simulated non-continuous linetypes that are comprised many individual segments instead of a single line with a linetyp
;;; WobblyPline.LSP [Command name: WPL]
;;; To draw a Polyline that wobbles "randomly" from the plain path created or selected.
;;; Options:
;;; 1. create new, or select EXisting, path of any appropriate type;
;;; 2. number of line segments in resulting polyline;
;;; 3. degree of randomization [as a percentage of average segment length];
;;; 4. after first use, re-use PRevious path [changing any or all choices], or
;;; 5. after first use, Redo wholesale, using previous path and all previous choices;
;;; 6. Retain or Delete base path.
;;; Under Existing-path option, asks User to select again if nothing selected, or selected object
;;; is an inappropriate entity type, or is on a locked Layer under Delete-path option.
;;; Draws 3DPolyline [randomized only in X-Y direction] if path is one; otherwise draws 2D
;;; ["lightweight"] Pline.
;;; Draws on current Layer, unless Deleting Existing path; if so, draws on its Layer.
;;; Remembers choices and offers them as defaults for subsequent use.
;;;
;;; Kent Cooper, October 2008
;
(defun C:WPL (/ *error* cmde osm typetemp pathsel deltemp 3Dpath segtemp pcttemp
segavg maxdis intpt blips base angdisp distdisp)
;
(defun *error* (errmsg)
(if (/= errmsg "Function cancelled") (princ (strcat "\nError: " errmsg)))
(setvar 'osmode osm)
(setvar 'blipmode blips)
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); end defun *error*
;
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(setq
blips (getvar 'blipmode)
osm (getvar 'osmode)
); end setq
(setvar 'osmode 0)
;
(if *wpl*
(initget "Line Arc Circle Pline 3dpoly Ellipse Spline EXisting PRevious Redo")
(initget "Line Arc Circle Pline 3dpoly Ellipse Spline EXisting"); no PR/R options on first use
); end if
(setq typetemp
(getkword
(strcat
"\nPath type [new Line(single)/Arc/Circle/Pline(2D)/3dpoly/Spline/Ellipse, or EXisting"
(if *wpl*
"/PRevious/Redo"
""
); end if
"] <"
(if *wpl* *wpltype* "Pline"); at first use, Polyline default; otherwise, previous type
">: "
); end strcat
); end getkword
*wpltype*
(cond
(typetemp); if User typed something other than Enter, use it
(*wpltype*); if Enter and there's a previous type, use that
(T "Pline"); otherwise [Enter on first use], Polyline default
); end cond & *wpltype*
); end setq
;
(if (= *wpltype* "PRevious") (entdel *wpl*)); if re-using Previous path with option
; of new choices [but not wholesale Redo], delete previous wobbly Polyline
(if (and (= *wpltype* "PRevious") (= *wpldel* "Delete")) (entdel *wplpath*)); bring back Previous path
;
(if (/= *wpltype* "Redo"); if not Redoing,
(progn
(initget "Retain Delete")
(setq
deltemp
(getkword
(strcat
"\nRetain or Delete base path [R/D] <"
(if *wpl* (substr *wpldel* 1 1) "D"); at first use, Delete default; otherwise, previous type
">: "
); end strcat
); end getkword
*wpldel*
(cond
(deltemp); if User typed something, use it
(*wpldel*); if Enter and there's a previous choice, use that
(T "Delete"); otherwise [Enter on first use], Delete
); end cond & *wpldel*
); end setq
); end progn
); end if
;
(cond ; select or make path
((and (= *wpltype* "EXisting") (= *wpldel* "Delete")); check selected object for locked Layer if Delete option
(prompt "\nTo make an EXisting path wobbly,")
(while
(not
(and
(setq pathsel (ssget ":S" '((0 . "LINE,ARC,CIRCLE,LWPOLYLINE,POLYLINE,ELLIPSE,SPLINE"))))
(= (cdr (assoc 70 (tblsearch "layer" (cdr (assoc 8 (entget (ssname pathsel 0))))))) 0); 0 for Unlocked, 4 for Locked
); end and
); end not
(prompt "\nNothing selected, or object is not a finite path type, or is on a Locked Layer; try again:")
); end while
); end first condition - EXisting with Delete
((= *wpltype* "EXisting")
(prompt "\nTo make an EXisting path wobbly,")
(while
(not (setq pathsel (ssget ":S" '((0 . "LINE,ARC,CIRCLE,LWPOLYLINE,POLYLINE,ELLIPSE,SPLINE")))))
(prompt "\nNothing selected, or object is not a finite path type; try again:")
); end while
); end second condition - EXisting with Retain
((and (= *wpltype* "Redo") (= *wpldel* "Delete")) (entdel *wplpath*)); bring back path
((= *wpltype* "Line") (setvar 'cmdecho 1) (command "_.line" pause pause "") (setvar 'cmdecho 0))
((not (or (= *wpltype* "Redo") (= *wpltype* "PRevious"))); all other entity types
(setvar 'cmdecho 1)
(command *wpltype*)
(while (> (getvar 'cmdactive) 0) (command pause))
(setvar 'cmdecho 0)
); end fourth condition
); end cond
;
(setq
*wplpath* ; set object as base path
(cond
((= *wpltype* "EXisting") (ssname pathsel 0))
((or (= *wpltype* "Redo") (= *wpltype* "PRevious")) *wplpath*)
((entlast)); newly created path
); end cond & *wplpath*
pathlength (vlax-curve-getDistAtParam *wplpath* (vlax-curve-getEndParam *wplpath*))
3Dpath (= (cdr (assoc 0 (entget *wplpath*))) "POLYLINE")
); end setq
;
(if (/= *wpltype* "Redo"); if not Redoing,
(progn ; then - ask for other input
;
(if *wpl* (initget 6) (initget 7)); no Enter on first use, no 0, no negative
(setq
segtemp
(getint
(strcat
"\nNumber of segments"
(if *wplseg* (strcat " <" (itoa *wplseg*) ">") ""); no default on first use
": "
); end strcat
); end getint
*wplseg* (if segtemp segtemp *wplseg*)
); end setq
;
(if *wplpct* (initget 4) (initget 5)); no Enter on first use, 0 allowed, no negative
(setq
pcttemp
(getreal
(strcat
"\nMaximum displacement as percentage of average segment length"
(if *wplpct* (strcat " <" (rtos *wplpct* 2 2) ">") ""); no default on first use
": "
); end strcat
); end getreal
*wplpct* (if pcttemp pcttemp *wplpct*)
); end setq
;
); end progn - not Redoing
(entdel *wpl*); else - if Redoing, eliminate previous one
); end if
;
(setq
segavg (/ pathlength *wplseg*)
maxdis (* segavg *wplpct* 0.01); maximum displacement
intpt 1 ; starting value for intermediate point
); end setq
(setvar 'blipmode 0)
;
(if (not 3Dpath) (command "_.ucs" "_new" "_object" *wplpath*)) ; set UCS to match object if appropriate
(if (= *wpldel* "Delete") (setvar 'clayer (cdr (assoc 8 (entget *wplpath*))))) ; if Deleting Existing path, draw on same Layer
;
(command
(if 3Dpath "3dpoly" "_.pline"); command type - Pline for all but 3D Polylines
(trans (vlax-curve-getStartPoint *wplpath*) 0 1)
(while (< intpt *wplseg*)
(setq
base (vlax-curve-getPointAtDist *wplpath* (* segavg intpt)); un-randomized intermediate location
angdisp (* 2 pi (/ (atoi (substr (rtos (rem (getvar 'cdate) 1) 2 16) (- 17 (fix (rem (cadr base) 3)) (fix (abs (* (sin intpt) 10)))) 2)) 100.0))
; randomized angle
distdisp (* maxdis (/ (atoi (substr (rtos (rem (getvar 'date) 1) 2 16) (- 18 (rem (fix (sqrt (abs (car base)))) 5) (rem intpt 3)) 2)) 100.0))
; randomized distance
intpt (1+ intpt); increment intermediate point number
); end setq
(command (polar (trans base 0 1) angdisp distdisp)); feed randomized location out to Pline or 3dpoly command
(if (vlax-curve-isClosed *wplpath*)
"_close"
(trans (vlax-curve-getEndPoint *wplpath*) 0 1); last point for open path
); end if
); end while
(if (not (vlax-curve-isClosed *wplpath*)) ""); end Pline or 3dpoly for open path
); end command - pline or 3dpoly
;
(if (not 3Dpath) (command "_.ucs" "_prev")); reset UCS if appropriate
(if (and (or (= *wpltype* "EXisting") (= *wpltype* "PRevious") (= *wpltype* "Redo")) (= *wpldel* "Delete")) (command "_.layerp"))
; reset Layer if appropriate
;
(if (= *wpldel* "Delete") (entdel *wplpath*))
(setq *wpl* (entlast))
(setvar 'osmode osm)
(setvar 'blipmode blips)
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); end defun
(prompt "Type WPL to make a Wobbly PolyLine.")
Don't know what this is :-(Edit
;;
;;;
;;; By Dominic Panholzer
;;;
;;; Modified original TXTEXP.LSP from Express Tools
;;; Copyright © 1999 by Autodesk, Inc.
;; LINEXP.LSP modifications by XANADU
;;;
;;; Your use of this software is governed by the terms and conditions of the
;;; License Agreement you accepted prior to installation of this software.
;;; Please note that pursuant to the License Agreement for this software,
;;; "[c]opying of this computer program or its documentation except as
;;; permitted by this License is copyright infringement under the laws of
;;; your country. If you copy this computer program without permission of
;;; Autodesk, you are violating the law."
;;;
;;; AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;; AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. AUTODESK, INC.
;;; DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;; UNINTERRUPTED OR ERROR FREE.
;;;
;;; Use, duplication, or disclosure by the U.S. Government is subject to
;;; restrictions set forth in FAR 52.227-19 (Commercial Computer
;;; Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;; (Rights in Technical Data and Computer Software), as applicable.
;;;
;;; ----------------------------------------------------------------
;;;
;;; External Functions:
;;;
;;; ACET-ERROR-INIT --> ACETUTIL.FAS Intializes bonus error routine
;;; ACET-ERROR-RESTORE --> ACETUTIL.FAS Restores old error routine
;;; ACET-GEOM-ZOOM-FOR-SELECT --> ACETUTIL.FAS Zoom boundry to include points given
;;; ACET-LAYER-LOCKED --> ACETUTIL.FAS Checks to see if layer is locked
;;; ACET-GEOM-PIXEL-UNIT --> ACETUTIL.FAS Size of pixel in drawing units
;;; ACET-GEOM-TEXTBOX --> ACETUTIL.FAS Returns the textbox for any text
;;; ACET-GEOM-MIDPOINT --> ACETUTIL.FAS Returns midpoint between two points
;;; ACET-GEOM-VIEW-POINTS --> ACETUTIL.FAS Returns corner points of screen or viewport
;;; ACET-STR-FORMAT --> ACETUTIL.ARX String builder
;;; ACET-WMFIN --> ACETUTIL.FAS Brings in WMF file
;;;
(defun c:linexp (/ grplst getgname blknm FLTR GLST GDICT SS VIEW UPLFT TMPFIL TBX
TMPFIL CNT PT1 PT2 ENT TXT TXTYP PTLST ZM LOCKED GNAM vpna vplocked)
(acet-error-init
(list
(list "cmdecho" 0
"highlight" 1
"osmode" 0
"Mirrtext" 1
"limcheck" 0
)
T
)
)
; --------------------- GROUP LIST FUNCTION ----------------------
; This function will return a list of all the group names in the
; drawing and their entity names in the form:
; ((<ename1> . <name1>) ... (<enamex> . <namex>))
; ----------------------------------------------------------------
(defun acet-txtexp-grplst (/ GRP ITM NAM ENT GLST)
(setq GRP (dictsearch (namedobjdict) "ACAD_GROUP"))
(while (setq ITM (car GRP)) ; While edata item is available
(if (= (car ITM) 3) ; if the item is a group name
(setq NAM (cdr ITM) ; get the name
GRP (cdr GRP) ; shorten the edata
ITM (car GRP) ; get the next item
ENT (cdr ITM) ; which is the ename
GRP (cdr GRP) ; shorten the edata
GLST ; store the ename and name
(if GLST
(append GLST (list (cons ENT NAM)))
(list (cons ENT NAM))
)
)
(setq GRP (cdr GRP)) ; else shorten the edata
)
)
GLST ; return the list
)
; ------------------- GET GROUP NAME FUNCTION --------------------
; This function returns a list of all the group names in GLST
; where ENT is a member. The list has the same form as GLST
; ----------------------------------------------------------------
(defun acet-txtexp-getgname (ENT GLST / GRP GDATA NAM NLST)
(if (and GLST (listp GLST))
(progn
(foreach GRP GLST
(setq GDATA (entget (car GRP)))
(foreach ITM GDATA ; step through the edata
(if (and
(= (car ITM) 340) ; if the item is a entity name
(eq (setq NAM (cdr ITM)) ENT) ; and the ename being looked for
)
(setq NLST ; store the ename and name
(if NLST
(append NLST (list (cons (car GRP) (cdr GRP))))
(list (cons (car GRP) (cdr GRP)))
)
)
)
)
)
)
)
NLST
)
; ----------------------------------------------------------------
; MAIN PROGRAM
; ----------------------------------------------------------------
(if (and ; Are we in plan view?
(equal (car (getvar "viewdir")) 0 0.00001)
(equal (cadr (getvar "viewdir")) 0 0.00001)
(> (caddr (getvar "viewdir")) 0)
)
(progn
(prompt "\nSelect lines to be EXPLODED: ")
(Setq FLTR '((-4 . "<AND")
(-4 . "<OR") ; filter for mtext and text
(0 . "MTEXT")
(0 . "TEXT")
(-4 . "OR>")
(-4 . "<NOT")
(102 . "{ACAD_REACTORS") ; and not leader text
(-4 . "NOT>")
(-4 . "AND>")
)
GLST (acet-txtexp-grplst) ; Get all the groups in drawing
GDICT (if GLST
(dictsearch (namedobjdict) "ACAD_GROUP")
)
SS (ssget); FLTR)
CNT 0
)
;; filter out the locked layers
(if SS
(setq SS (car (bns_ss_mod SS 1 T)))
) ;if
;; if we have anything left
(if SS
(progn
(setq CNT 0) ; Reset counter
(while (setq ENT (ssname SS CNT)) ; step through each object in set
(and
GLST ; if groups are present in the drawing
(setq GNAM (acet-txtexp-getgname ENT GLST)) ; and the text item is in one or more
(foreach GRP GNAM ; step through those groups
(command "_.-group" "_r" ; and remove the text item
(cdr GRP) ENT ""
)
)
)
(setq TBX (acet-geom-textbox (entget ENT) 0)) ; get textbox points
(setq TBX (mapcar '(lambda (x)
(trans x 1 0) ; convert the points to WCS
)
TBX
)
)
(setq PTLST (append PTLST TBX)) ; Build list of bounding box
; points for text items selected
(setq CNT (1+ CNT)) ; get the next text item
); while
(setq PTLST (mapcar '(lambda (x)
(trans x 0 1) ; convert all the points
) ; to the current ucs
PTLST
)
)
(if (setq ZM (acet-geom-zoom-for-select PTLST)) ; If current view does not contain
(progn ; all bounding box points
(setq ZM
(list
(list (- (caar ZM) (acet-geom-pixel-unit)) ; increase zoom area by
(- (cadar ZM) (acet-geom-pixel-unit)) ; one pixel width to
(caddar ZM) ; sure nothing will be lost
)
(list (+ (caadr ZM) (acet-geom-pixel-unit))
(+ (cadadr ZM) (acet-geom-pixel-unit))
(caddr (cadr zm))
)
)
)
(if (setq vpna (acet-currentviewport-ename))
(setq vplocked (acet-viewport-lock-set vpna nil))
);if
(command "_.zoom" "_w" (car ZM) (cadr ZM)) ; zoom to include text objects
)
)
(setq VIEW (acet-geom-view-points)
TMPFIL (strcat (getvar "tempprefix") "txtexp.wmf")
PT1 (acet-geom-midpoint (car view) (cadr view))
PT2 (list (car PT1) (cadadr VIEW))
)
(if (acet-layer-locked (getvar "clayer")) ; if current layer is locked
(progn
(command "_.layer" "_unl" (getvar "clayer") "") ; unlock it
(setq LOCKED T)
)
)
(command "_.mirror" SS "" PT1 PT2 "_y"
"_.WMFOUT" TMPFIL SS "")
(if (findfile tmpfil) ; Does WMF file exist?
(progn
(command "_.ERASE" SS "") ; erase the orignal text
(setq ss (acet-wmfin TMPFIL)) ; insert the WMF file
(command "_.mirror" ss "" PT1 PT2 "_y")
) ;progn
) ;if
(if LOCKED
(command "_.layer" "_lock" (getvar "clayer") "") ; relock if needed
) ;if
(if ZM (command "_.zoom" "_p")) ; Restore original view if needed
(if vplocked
(acet-viewport-lock-set vpna T) ;re-lock the viewport if needed.
);if
(prompt (acet-str-format "\n%1 object(s) have been exploded to lines." CNT))
(prompt "\nThe line objects have been placed on layer 0.")
)
)
)
(prompt "\nView needs to be in plan (0 0 1).")
);if equal
(acet-error-restore) ; Retsore values
(princ)
)
(princ)
Explode Text to lines Command: TXTEXP2Edit
Tip: zoom in maximally on the text to be exploded prior to the command. This increases the resolution of the result.
;;
;;;
;;; By Dominic Panholzer
;;;
;;; TXTEXP.LSP
;;; Copyright © 1999 by Autodesk, Inc.
;;;
;;; Your use of this software is governed by the terms and conditions of the
;;; License Agreement you accepted prior to installation of this software.
;;; Please note that pursuant to the License Agreement for this software,
;;; "[c]opying of this computer program or its documentation except as
;;; permitted by this License is copyright infringement under the laws of
;;; your country. If you copy this computer program without permission of
;;; Autodesk, you are violating the law."
;;;
;;; AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;; AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. AUTODESK, INC.
;;; DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;; UNINTERRUPTED OR ERROR FREE.
;;;
;;; Use, duplication, or disclosure by the U.S. Government is subject to
;;; restrictions set forth in FAR 52.227-19 (Commercial Computer
;;; Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;; (Rights in Technical Data and Computer Software), as applicable.
;;;
;;; ----------------------------------------------------------------
;;;
;;; External Functions:
;;;
;;; ACET-ERROR-INIT --> ACETUTIL.FAS Intializes bonus error routine
;;; ACET-ERROR-RESTORE --> ACETUTIL.FAS Restores old error routine
;;; ACET-GEOM-ZOOM-FOR-SELECT --> ACETUTIL.FAS Zoom boundry to include points given
;;; ACET-LAYER-LOCKED --> ACETUTIL.FAS Checks to see if layer is locked
;;; ACET-GEOM-PIXEL-UNIT --> ACETUTIL.FAS Size of pixel in drawing units
;;; ACET-GEOM-TEXTBOX --> ACETUTIL.FAS Returns the textbox for any text
;;; ACET-GEOM-MIDPOINT --> ACETUTIL.FAS Returns midpoint between two points
;;; ACET-GEOM-VIEW-POINTS --> ACETUTIL.FAS Returns corner points of screen or viewport
;;; ACET-STR-FORMAT --> ACETUTIL.ARX String builder
;;; ACET-WMFIN --> ACETUTIL.FAS Brings in WMF file
;;;
(defun c:txtexp2 (/ grplst getgname blknm FLTR GLST GDICT SS VIEW UPLFT TMPFIL TBX
TMPFIL CNT PT1 PT2 ENT TXT TXTYP PTLST ZM LOCKED GNAM vpna vplocked)
(acet-error-init
(list
(list "cmdecho" 0
"highlight" 1
"osmode" 0
"Mirrtext" 1
"limcheck" 0
)
T
)
)
; --------------------- GROUP LIST FUNCTION ----------------------
; This function will return a list of all the group names in the
; drawing and their entity names in the form:
; ((<ename1> . <name1>) ... (<enamex> . <namex>))
; ----------------------------------------------------------------
(defun acet-txtexp-grplst (/ GRP ITM NAM ENT GLST)
(setq GRP (dictsearch (namedobjdict) "ACAD_GROUP"))
(while (setq ITM (car GRP)) ; While edata item is available
(if (= (car ITM) 3) ; if the item is a group name
(setq NAM (cdr ITM) ; get the name
GRP (cdr GRP) ; shorten the edata
ITM (car GRP) ; get the next item
ENT (cdr ITM) ; which is the ename
GRP (cdr GRP) ; shorten the edata
GLST ; store the ename and name
(if GLST
(append GLST (list (cons ENT NAM)))
(list (cons ENT NAM))
)
)
(setq GRP (cdr GRP)) ; else shorten the edata
)
)
GLST ; return the list
)
; ------------------- GET GROUP NAME FUNCTION --------------------
; This function returns a list of all the group names in GLST
; where ENT is a member. The list has the same form as GLST
; ----------------------------------------------------------------
(defun acet-txtexp-getgname (ENT GLST / GRP GDATA NAM NLST)
(if (and GLST (listp GLST))
(progn
(foreach GRP GLST
(setq GDATA (entget (car GRP)))
(foreach ITM GDATA ; step through the edata
(if (and
(= (car ITM) 340) ; if the item is a entity name
(eq (setq NAM (cdr ITM)) ENT) ; and the ename being looked for
)
(setq NLST ; store the ename and name
(if NLST
(append NLST (list (cons (car GRP) (cdr GRP))))
(list (cons (car GRP) (cdr GRP)))
)
)
)
)
)
)
)
NLST
)
; ----------------------------------------------------------------
; MAIN PROGRAM
; ----------------------------------------------------------------
(if (and ; Are we in plan view?
(equal (car (getvar "viewdir")) 0 0.00001)
(equal (cadr (getvar "viewdir")) 0 0.00001)
(> (caddr (getvar "viewdir")) 0)
)
(progn
(prompt "\nSelect text to be EXPLODED: ")
(Setq FLTR '((-4 . "<AND")
;(-4 . "<OR") ; filter for mtext and text
; (0 . "MTEXT")
; (0 . "TEXT")
;(-4 . "OR>")
(-4 . "<NOT")
(102 . "{ACAD_REACTORS") ; and not leader text
(-4 . "NOT>")
(-4 . "AND>")
)
GLST (acet-txtexp-grplst) ; Get all the groups in drawing
GDICT (if GLST
(dictsearch (namedobjdict) "ACAD_GROUP")
)
SS (ssget FLTR)
CNT 0
)
;; filter out the locked layers
(if SS
(setq SS (car (bns_ss_mod SS 1 T)))
) ;if
;; if we have anything left
(if SS
(progn
(setq CNT 0) ; Reset counter
(while (setq ENT (ssname SS CNT)) ; step through each object in set
(and
GLST ; if groups are present in the drawing
(setq GNAM (acet-txtexp-getgname ENT GLST)) ; and the text item is in one or more
(foreach GRP GNAM ; step through those groups
(command "_.-group" "_r" ; and remove the text item
(cdr GRP) ENT ""
)
)
)
(setq TBX (acet-geom-textbox (entget ENT) 0)) ; get textbox points
(setq TBX (mapcar '(lambda (x)
(trans x 1 0) ; convert the points to WCS
)
TBX
)
)
(setq PTLST (append PTLST TBX)) ; Build list of bounding box
; points for text items selected
(setq CNT (1+ CNT)) ; get the next text item
); while
(setq PTLST (mapcar '(lambda (x)
(trans x 0 1) ; convert all the points
) ; to the current ucs
PTLST
)
)
(if (setq ZM (acet-geom-zoom-for-select PTLST)) ; If current view does not contain
(progn ; all bounding box points
(setq ZM
(list
(list (- (caar ZM) (acet-geom-pixel-unit)) ; increase zoom area by
(- (cadar ZM) (acet-geom-pixel-unit)) ; one pixel width to
(caddar ZM) ; sure nothing will be lost
)
(list (+ (caadr ZM) (acet-geom-pixel-unit))
(+ (cadadr ZM) (acet-geom-pixel-unit))
(caddr (cadr zm))
)
)
)
(if (setq vpna (acet-currentviewport-ename))
(setq vplocked (acet-viewport-lock-set vpna nil))
);if
(command "_.zoom" "_w" (car ZM) (cadr ZM)) ; zoom to include text objects
)
)
(setq VIEW (acet-geom-view-points)
TMPFIL (strcat (getvar "tempprefix") "txtexp.wmf")
PT1 (acet-geom-midpoint (car view) (cadr view))
PT2 (list (car PT1) (cadadr VIEW))
)
(if (acet-layer-locked (getvar "clayer")) ; if current layer is locked
(progn
(command "_.layer" "_unl" (getvar "clayer") "") ; unlock it
(setq LOCKED T)
)
)
(command "_.mirror" SS "" PT1 PT2 "_y"
"_.WMFOUT" TMPFIL SS "")
(if (findfile tmpfil) ; Does WMF file exist?
(progn
(command "_.ERASE" SS "") ; erase the orignal text
(setq ss (acet-wmfin TMPFIL)) ; insert the WMF file
(command "_.mirror" ss "" PT1 PT2 "_y")
) ;progn
) ;if
(if LOCKED
(command "_.layer" "_lock" (getvar "clayer") "") ; relock if needed
) ;if
(if ZM (command "_.zoom" "_p")) ; Restore original view if needed
(if vplocked
(acet-viewport-lock-set vpna T) ;re-lock the viewport if needed.
);if
(prompt (acet-str-format "\n%1 text object(s) have been exploded to lines." CNT))
(prompt "\nThe line objects have been placed on layer 0.")
)
)
)
(prompt "\nView needs to be in plan (0 0 1).")
);if equal
(acet-error-restore) ; Retsore values
(princ)
)
(princ)
;;;-----BEGIN-SIGNATURE-----
;;; aAcAADCCB2QGCSqGSIb3DQEHAqCCB1UwggdRAgEBMQ8wDQYJKoZIhvcNAQELBQAw
;;; CwYJKoZIhvcNAQcBoIIFBjCCBQIwggPqoAMCAQICEGS8scfO5NpYadWPHiL76fQw
;;; DQYJKoZIhvcNAQELBQAwfzELMAkGA1UEBhMCVVMxHTAbBgNVBAoTFFN5bWFudGVj
;;; IENvcnBvcmF0aW9uMR8wHQYDVQQLExZTeW1hbnRlYyBUcnVzdCBOZXR3b3JrMTAw
;;; LgYDVQQDEydTeW1hbnRlYyBDbGFzcyAzIFNIQTI1NiBDb2RlIFNpZ25pbmcgQ0Ew
;;; HhcNMTUwOTAzMDAwMDAwWhcNMTYwOTAyMjM1OTU5WjCBiDELMAkGA1UEBhMCVVMx
;;; EzARBgNVBAgMCkNhbGlmb3JuaWExEzARBgNVBAcMClNhbiBSYWZhZWwxFjAUBgNV
;;; BAoMDUF1dG9kZXNrLCBJbmMxHzAdBgNVBAsMFkRlc2lnbiBTb2x1dGlvbnMgR3Jv
;;; dXAxFjAUBgNVBAMMDUF1dG9kZXNrLCBJbmMwggEiMA0GCSqGSIb3DQEBAQUAA4IB
;;; DwAwggEKAoIBAQDqmfToz8wEanfXT+H6tql3aUyaJRWCfFsYPFnGVXIl95fnZY3s
;;; OEfQvFkf9LVte5SwDWkjkReCGJlk4HaRYOTxkd7PkeAOOtYaUSBvULYRlKvAbe2n
;;; +VWwo4yrWATav8d7pKlbMP9f6pYxlaZQzsq/e+pLZwptP8C9Dfrm5OVgCIL/iPRN
;;; Iuvhl9YUZvnkZYmCnihdP4AS8g4d7rfjdxzT653433nO6tgs3fNgnkQQk6EdROwq
;;; esgQXRlH29yRND5xNfup9KiZ7L7Nm7AiM6laNwNIjBwbG4qMWuQ2Ml7hHzQpLaLF
;;; JRV33oHedeGSZ7OmA6+D5WoQtPpSt4YCcub5AgMBAAGjggFuMIIBajAJBgNVHRME
;;; AjAAMA4GA1UdDwEB/wQEAwIHgDATBgNVHSUEDDAKBggrBgEFBQcDAzBmBgNVHSAE
;;; XzBdMFsGC2CGSAGG+EUBBxcDMEwwIwYIKwYBBQUHAgEWF2h0dHBzOi8vZC5zeW1j
;;; Yi5jb20vY3BzMCUGCCsGAQUFBwICMBkaF2h0dHBzOi8vZC5zeW1jYi5jb20vcnBh
;;; MB8GA1UdIwQYMBaAFJY7U/B5M5evfYPvLivMyreGHnJmMCsGA1UdHwQkMCIwIKAe
;;; oByGGmh0dHA6Ly9zdi5zeW1jYi5jb20vc3YuY3JsMFcGCCsGAQUFBwEBBEswSTAf
;;; BggrBgEFBQcwAYYTaHR0cDovL3N2LnN5bWNkLmNvbTAmBggrBgEFBQcwAoYaaHR0
;;; cDovL3N2LnN5bWNiLmNvbS9zdi5jcnQwEQYJYIZIAYb4QgEBBAQDAgQQMBYGCisG
;;; AQQBgjcCARsECDAGAQEAAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQAegWHWPJ8y1kt5
;;; 7JP8TOQlnYs0eMMg5/MHxlW3LhKv/PG8jZ2NDg8YrGuwBC7y3um+PA6KxRT9px8N
;;; KjniMX4NsPtQ81s2EITHy4uFfz6dTpgmL2BLE2/6FPmG4koEhY6zeT4tizeTscOR
;;; Mu1gCtr4Vq+BC/+0Ax6LKOGt5Ut1pJT89ivzZYZOIvEtt9AZRgh7GRg2Oz7X6MFn
;;; c3KudMQhCEnBEUkbS3fmC+kll5PuoF/R1XBcbby0ODfQ3xfwSpNd6WIMr2T5HnSC
;;; gOMmAsuP1Y6LjaCoYDP2mhiwMg797o0XVywnKLEeDGw/F9b/c+lpIBuWGWYnFjz7
;;; CTe7cgdcMYICIjCCAh4CAQEwgZMwfzELMAkGA1UEBhMCVVMxHTAbBgNVBAoTFFN5
;;; bWFudGVjIENvcnBvcmF0aW9uMR8wHQYDVQQLExZTeW1hbnRlYyBUcnVzdCBOZXR3
;;; b3JrMTAwLgYDVQQDEydTeW1hbnRlYyBDbGFzcyAzIFNIQTI1NiBDb2RlIFNpZ25p
;;; bmcgQ0ECEGS8scfO5NpYadWPHiL76fQwDQYJKoZIhvcNAQELBQAwDQYJKoZIhvcN
;;; AQEBBQAEggEAmSz+IdPijM5uu5K6Ee6RHvKaLXMKoETIyjFhaW8Llu/XTPb2Ka1k
;;; VQfzwgyRsC5XtKRrfuD1MwHOvy+NK79mV06Oj6d7IRSLsta4l+e1whMVg/lChXG1
;;; yEY1nYNfVXaf1FOkV4hRHj1/53kxA5zhAWs8Q2P/jgAhjZILAEWxPaZ8OLH6Wh/Z
;;; vAwZbZT31TTQSqTUlZlI9uG95QvyF95Wj/TBklcNxEUoM9IgnPvlxVbViK0IwBwp
;;; 6X2f2b4h6GidqYWsRkBc5vOyhJGcSuam2IiNQZzpsYRperbScF0M5ZxuQ3x1o98C
;;; rOhBAib2Dbu/adetPDoUUFW7X+U6fedtJ6FhMF8GA1UdDjFYBFYzADkAOwAyAC8A
;;; NwAvADIAMAAxADYALwA1AC8AOQAvADMANAAvAFQAaQBtAGUAIABmAHIAbwBtACAA
;;; dABoAGkAcwAgAGMAbwBtAHAAdQB0AGUAcgAAAA==
;;; -----END-SIGNATURE-----
Table Export to CSV Command: TABLEEXPORTEdit
;---------------------------------------------------------------------------------------------------------------------------------
;-------------------------------------- GATHERING TABLE INFORMATION ------------------------------------
;---------------------------------------------------------------------------------------------------------------------------------
(defun tableinfo ( ss / n entlist)
(setq n 0)
(repeat (sslength ss)
(setq entlist (entget (ssname ss n)))
(cond ((member (cdr (assoc 0 entlist)) '("LINE" "POLYLINE"))
(getlinepts entlist)(setq linelist (cons (ssname ss n) linelist)))
((member (cdr (assoc 0 entlist)) '("TEXT" "MTEXT"))
(setq textlist (cons (ssname ss n) textlist)))
((member (cdr (assoc 0 entlist)) '("INSERT"))
(setq blocklist (cons (ssname ss n) blocklist)))
)
(setq n (1+ n))
)
)
;-------------------------- Cell Count/Height/Width Determination ----------------------
;;Gathers x and y positions of lines and polylines in separate lists
;;This is used to determine height/width & # of rows/columns
;;Line info must be gathered first in order to determine
;;cell position of any other gathered information
;---------------------------------------------------------------------------------------
(defun getlinepts (alist / x xpt ypt)
(foreach x alist
(if (member (car x) '(10 11))
(progn
(if (not (vl-position (setq xpt (atof (rtos (car (trans (cdr x) 0 1)) 2 2))) lpxlist))
(setq lpxlist (cons xpt lpxlist)))
(if (not (vl-position (setq ypt (atof (rtos (cadr (trans (cdr x) 0 1)) 2 2))) lpylist))
(setq lpylist (cons ypt lpylist)))
)
)
)
);defun
;---------------------------- Text Info and Cell Position -----------------------------------------------------
;;Determine cell position by insertionpoint of text objects
;;(Using text center is probably more reliable)
;;Create list of indexed lists containing "Order", "Position", "Content", "Height", "Rotation", "StyleName" and "TrueColor"
;;to be used to fill acad table after creation
;;If row and column is already in list, replace with combined string
;--------------------------------------------------------------------------------------------------------------
(defun gettxtinfo (alist / x vlaobj pos rpos cpos expos)
(setq vlaobj (vlax-ename->vla-object txt)
pos (trans (midp vlaobj) 0 1);Midpoint
rpos (1- (vl-position (cadr pos)(vl-sort (cons (cadr pos) lpylist) '>)));Row Position
cpos (1- (vl-position (car pos) (vl-sort (cons (car pos) lpxlist) '<))));Column Position
(if (setq expos (vl-position (list rpos cpos) (mapcar '(lambda (x)(cdr (assoc "Position" x))) tinfo)));if cell is taken
(setq tinfo
(replace tinfo expos
(replace
(nth expos tinfo)
2
(cons "Content"
(if (> (cadr pos) (cdr (assoc "Order" (nth expos tinfo))));in order according to y position
(strcat (vla-fieldcode vlaobj) " " (cdr (assoc "Content" (nth expos tinfo))))
(strcat (cdr (assoc "Content" (nth expos tinfo))) " " (vla-fieldcode vlaobj))
)))))
(setq tinfo
(cons
(list
(Cons "Order" (cadr pos))
(Cons "Position" (list rpos cpos));Position
(Cons "Content" (vla-fieldcode vlaobj));Content
(Cons "Height" (vla-get-height vlaobj))
(Cons "Rotation" (vla-get-rotation vlaobj))
(Cons "StyleName" (vla-get-StyleName vlaobj))
(Cons "TrueColor"
(if
(= (vla-get-colorindex (vla-get-truecolor vlaobj)) 256)
(vla-get-truecolor
(vla-item
(vla-get-layers ActDoc)
(vla-get-layer vlaobj)))
(vla-get-truecolor vlaobj)
)
)
)
tinfo)))
;(vla-delete vlaobj)
);defun
;--------------------------- Block Info and Cell Position -------------------------------------------------------
;;Gather block information
;;determine cell position according to insertion point
;;Create an indexed list of lists containing "Position" (row, column), "ObjID",
;;"Attributes" (attribute id, attributetextstring) and "Scale"
;----------------------------------------------------------------------------------------------------------------
(defun getblockinfo (obj / pos rpos cpos bname objid bobj attid)
(if (= (type obj) 'ename)
(setq obj (vlax-ename->vla-object obj))
)
(setq pos (trans (midp obj) 0 1)
rpos (1- (vl-position (cadr pos)(vl-sort (cons (cadr pos) lpylist) '>)));Row Position
cpos (1- (vl-position (car pos) (vl-sort (cons (car pos) lpxlist) '<)));Column Position
bname (vla-get-name obj);Block Name
bobj (vla-item (vla-get-blocks ActDoc) bname));Block Vla Object
(vlax-for i bobj ; Foreach item in block
(if (eq (vla-get-objectname i) "AcDbAttributeDefinition");If item is an attribute
(setq attid (append attid (list (vla-get-objectid i))));List Attribute Id
)
)
(setq objid (vla-get-objectid bobj));Block Object Id
(setq binfo
(cons
(list
(Cons "Name" bname)
(Cons "Position" (list rpos cpos))
(Cons "ObjID" objid)
(if (= (vla-get-hasattributes obj) :vlax-true)
(Cons "Attributes"
(reverse
(mapcar
'(lambda (x y) (cons y (vla-get-textstring x)))
(vlax-safearray->list (variant-value (vla-getattributes obj)))
attid
)
)
)
)
(Cons "Scale" (vla-get-xscalefactor obj))
)
binfo))
)
;------------------------------------------------------------------------------------------------------------------------
;-------------------------------------------- REPLACE by Charles Alan Butler---------------------------------------------
;;Cab's replace function used in this routine to avoid overwriting cells and to update cell merge lists
;------------------------------------------------------------------------------------------------------------------------
(defun replace (lst i itm)
(setq i (1+ i))
(mapcar
'(lambda (x)
(if (zerop (setq i (1- i))) itm x)
)
lst
)
)
;-------------------------Midpoint-----------------
(defun midp (obj / ObjLl ObjUr)
(vla-GetBoundingBox obj 'ObjLl 'ObjUr)
(mapcar
'(lambda (a b) (/ (+ a b) 2.0))
(safearray-value ObjLl)
(safearray-value ObjUr))
)
;-------------------------Q&D Number Accumulation---------------------------
;Used in this routine for polar distances to determine which cells to merge.
;;Recursive function possible. Ask Gile (recursion master) if desired.
(defun acnumlist (nlist / acnlist)
(repeat (length nlist)
(setq acnlist (cons (apply '+ nlist) acnlist)
nlist (reverse (cdr (reverse nlist))))
)
acnlist
)
;--------------------------------------------------------------------------
;; ø Remove_nth ø (Lee Mac) ;;
;; ~ Removes the nth item in a list. ;;
(defun Remove_nth (i lst / j)
(setq j -1)
(vl-remove-if
(function
(lambda (x)
(eq i (setq j (1+ j))))) lst))
;;; private function (fixo)
(defun setcelltext(cells row column value)
(vl-catch-all-apply
'vlax-put-property
(list cells 'Item row column
(vlax-make-variant
(vl-princ-to-string value) 8)))
)
(defun setgridlines(xlapp range);(fixo)
;; select the range:
(vlax-invoke-method range 'Select)
;; get excel application selection property:
(setq range (vlax-get-property xlapp 'Selection))
;; get selection borders
(setq borders (vlax-get-property range 'Borders))
;; iterate through all edges of the selection
(setq cnt 0)
(vlax-for a borders
(setq cnt (1+ cnt))
(vl-catch-all-apply
(function
(lambda ()
(progn
(if (< cnt 5)
(progn
(vlax-put-property
a
'LineStyle
(vlax-make-variant 1 3)); single line style
(vlax-put-property
a
'Weight
(vlax-make-variant 2 3)); lines
(vlax-put-property
a
'ColorIndex
(vlax-make-variant 1 5))); color black
;; turn off the diagonal lines:
(vlax-put-property a 'LineStyle (vlax-make-variant -4142 3))
)
)
)
)
)
)
(princ)
)
(defun conexcelcolumn (/ a b list1);(Q. J. Chen)
(setq a 65)
(setq list1 nil)
(repeat 26
(setq list1 (append
list1
(list (chr a))
)
)
(setq a (1+ a))
)
(setq a 65)
(repeat 26
(setq b 65)
(repeat 26
(setq list1 (append
list1
(list (strcat (chr a) (chr b)))
)
)
(setq b (1+ b))
)
(setq a (1+ a))
)
list1
)
;;; private function
;;; apply props
(defun Orient (xlrange)
(mapcar '(lambda (prop value)
(vl-catch-all-apply
'vlax-put-property
(list xlrange
prop
value
)
)
)
(list 'HorizontalAlignment 'VerticalAlignment 'Orientation)
(list -4143 -4108 (cvunit (cdr (assoc "Rotation" x)) "radian" "degree"))
)
)
;---------------------------------------------------------------------------------------------------------------------
;------------------------------------------- CONVERT OLD TABLE ROUTINE -----------------------------------------------
;---------------------------------------------------------------------------------------------------------------------
(defun c:TE (/ ActDoc *error* orerror otcontents textlist colwidths i mlist p0 hmergelist2 vmergelist2
*Space* lpxlist lpylist tinfo cwidths check tstyle spos newstring
tstylelst blocklist rowheights selsets tstylelst2 tstylelst3
kword linelist binfo rheights hmergelist vmergelist ssitem tblobj mb
colorlst colorlst2 th tr ts tc newstyle RowTypes a acapp acsp address adoc atable borders cnt col data_list fname font prop release row
selrange sset txt_list urange value xlapp xlbook xlbooks xlcells xlrange xlsheet xlsheets)
(vl-load-com)
(setq oerror *error*)
(defun *error* ( msg )
(princ (strcat "\n<" msg ">\n"))
(mapcar '(lambda (x)(and x (not (vlax-object-released-p x))(vlax-release-object x))) (list ssitem))
(setq *error* oerror)
(setvar 'nomutt 0)
(vla-EndUndoMark ActDoc)
(princ)
);defun *error*
(setq ActDoc (vla-get-activedocument (vlax-get-acad-object))
*Space* (vlax-get-property ActDoc (nth (vla-get-ActiveSpace ActDoc)'("PaperSpace" "ModelSpace"))))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(setq otcontents (ssget))
(command "._zoom" "object" otcontents "")
(princ "\nSorting Line Info...")
(tableinfo otcontents)
(setq lpxlist (vl-sort lpxlist '<) lpylist (vl-sort lpylist '>))
(princ "\nSorting Text Info...")
(mapcar '(lambda (txt)(gettxtinfo (entget txt))(redraw txt 2)) textlist);;using redraw function To avoid interference
(princ "\nSorting Block Info...")
(mapcar '(lambda (blk)(getblockinfo blk)) blocklist)
(setq colwidths (mapcar '(lambda (x)(- (nth (1+ (vl-position x lpxlist)) lpxlist) x))(reverse (cdr (reverse lpxlist))))
rowheights (mapcar '(lambda (x)(- x (nth (1+ (vl-position x lpylist)) lpylist)))(reverse(cdr (reverse lpylist)))))
(setq p0 (vlax-3d-point (trans (list (car lpxlist) (car lpylist) 0.0) 1 0)));;<---Table Placement (Currently using Top Left corner)
(progn
(princ "\nSearching for merged cells...")
(princ)
(setvar 'nomutt 1)
;-----------------------------------Method to determine which cells to merge--------------------------------------------
;Method fails if missed selection is not possible at zoom level.
;To determine which cells to merge, a selection at point is used.
;For each row, a selection is attempted at each vertical line at row's center.
;If no selection is made, the point is at the center or left of horizontally merged cells.
;For each column, a selection is attempted at each horizontal line at column's center.
;If no selection is made, the point is at the center or upper region of vertically merged cells.
;Continuation of merging is determined by a 'consecutive miss'.
;When a 'consecutive miss' is made, max column/row item is replaced by the next column/row.
;-----------------------------------------------------------------------------------------------------------------------
(setq selsets (vla-get-selectionsets ActDoc))
(vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list selsets "InxCheckSet")))
(setq ssitem (vla-item selsets "InxCheckSet")
cwidths (acnumlist colwidths)
rheights (acnumlist rowheights));;col widths & row heights accumulated for polar use
(mapcar '(lambda (pt rh)
(mapcar '(lambda (x)
(vl-catch-all-error-p (vl-catch-all-apply 'vla-clear (list ssitem)))
(vla-selectatpoint ssitem (vlax-3d-point (polar (list (car lpxlist) (+ pt (/ rh 2)) 0.0) 0 x)))
(if (zerop (vla-get-count ssitem))
(if check
(setq hmergelist (replace hmergelist 0 (replace mlist 3 (1+ (vl-position x cwidths)))))
(setq hmergelist
(cons
(setq mlist
(list
(1- (vl-position pt lpylist))
(vl-position x cwidths)
(1- (vl-position pt lpylist))
(1+ (vl-position x cwidths))
)) hmergelist)
check T)
);if
(setq check nil mlist nil)
));lambda
cwidths
);mapcar
);lambda
(member (nth 1 lpylist) lpylist)
rowheights
);mapcar
(mapcar '(lambda (pt cw)
(mapcar '(lambda (x)
(vl-catch-all-error-p (vl-catch-all-apply 'vla-clear (list ssitem)))
(vla-selectatpoint ssitem (vlax-3d-point (polar (list (+ pt (/ cw 2)) (car lpylist) 0.0) (* pi 1.5) x)))
(if (zerop (vla-get-count ssitem))
(if check
(setq vmergelist (replace vmergelist 0 (replace mlist 2 (1+ (vl-position x rheights)))))
(setq vmergelist
(cons
(setq mlist
(list
(vl-position x rheights)
(vl-position pt lpxlist)
(1+ (vl-position x rheights))
(vl-position pt lpxlist)
)) vmergelist)
check T)
);if
(setq check nil mlist nil)
));lambda
rheights
);mapcar
);lambda
lpxlist
colwidths
);mapcar
(setvar 'nomutt 0)
);progn
(setq hmergelist2 (mapcar '(lambda (b)(list (car b)(cadr b))) hmergelist))
(setq vmergelist2 (mapcar '(lambda (b)(list (car b)(cadr b))) vmergelist))
(mapcar
'(lambda (a / expos)
(if
(setq expos (vl-position (list (car a)(cadr a)) vmergelist2))
(setq dmergelist (cons (list (car a)(cadr a)(caddr (nth expos vmergelist))(cadddr a)) dmergelist))))
hmergelist
)
(setq xlapp (vlax-get-or-create-object "Excel.Application");(fixo)
xlbooks (vlax-get-property xlapp 'Workbooks)
xlbook (vlax-invoke-method xlbooks 'Add)
xlsheets (vlax-get-property xlbook 'Sheets)
xlsheet (vlax-get-property xlsheets 'Item 1)
xlcells (vlax-get-property xlsheet 'Cells)
)
(vla-put-visible xlapp :vlax-true)
(vlax-invoke-method xlsheet "Activate")
(setq ecol (conexcelcolumn))
;place text
(mapcar '(lambda (x / r c xlrange)
(setq r (1+ (cadr (assoc "Position" x))) c (1+ (caddr (assoc "Position" x))))
(setcelltext xlcells r c (cdr (assoc "Content" x)))
(setq xlRange (vlax-get-property xlsheet "Range" (strcat (nth (1- c) ecol) (itoa r))))
(vlax-invoke-method xlRange "Select")
(setq xlRange (vlax-get-property xlapp "Selection"))
(Orient xlrange)
)
tinfo
)
;place block info
(mapcar '(lambda (x / r c bstring)
(setq r (1+ (cadr (assoc "Position" x))) c (1+ (caddr (assoc "Position" x))))
(setq bstring "")
(if (cdr (assoc "Attributes" x))
(progn
(mapcar
'(lambda (y )
(setq bstring (strcat ":"(cdr y) bstring)))
(cdr (assoc "Attributes" x)))
(setcelltext xlcells r c (strcat "Block:"(cdr (assoc "Name" x)) bstring))
));if
)
binfo
)
;merge cells
(princ "\nProcessing Merge Info")
;-------------------------------------------------------------------------------------------------------------------------
(defun convertlist ( mrglist / newmrglist)
(foreach x mrglist
(setq newmrglist (append newmrglist (list (strcat (nth (cadr x) ecol)(itoa (1+ (car x)))":" (nth (cadddr x) ecol)(itoa (1+ (caddr x)))))))
)
)
(defun applylist ( mrglist / xlRange)
(foreach x mrglist
(setq xlRange (vlax-get-property xlsheet "Range" x))
(vlax-invoke-method xlRange "Select")
(setq xlRange (vlax-get-property xlapp "Selection"))
(vlax-put-property xlRange "MergeCells" :vlax-true)
)
)
(setq hmergelist2 (convertlist hmergelist)
vmergelist2 (convertlist vmergelist))
(applylist hmergelist2)
(applylist vmergelist2)
(vlax-invoke-method
(vlax-get-property xlsheet 'Columns)
'AutoFit)
;;; align all columns to center
(vlax-put-property
(setq urange(vlax-get-property xlsheet 'UsedRange))
'HorizontalAlignment -4108)
;;; draw grid lines
(setgridlines xlapp urange)
(mapcar '(lambda (x);(fixo)
(vl-catch-all-apply
'(lambda ()
(vlax-release-object x)
)
)
)
(list xlcells xlsheet xlsheets xlbook xlbooks xlapp)
)
(setq xlapp nil)
(gc)(gc)(gc)
(mapcar '(lambda (x)(and x (not (vlax-object-released-p x))(vlax-release-object x))) (list ssitem))
(mapcar '(lambda (txt)(redraw txt 1)) textlist);;using redraw function again
(setq *error* oerror)
(vla-EndUndoMark ActDoc)
(princ)
(princ)
);defun;; BREAKUP Commands for AutoCAD Linetypes---------UNDER CONSTRUCTION
;; BreakUp.lsp [command names: BU- followed by linetype name]
;; Kent Cooper, last edited June 2011
;;
;; To Break Up linear entities into separate short entities and gaps, and/or add points
;; where appropriate, to emulate the appearance of non-continuous linetypes.
;; With closed objects, must check for entity type, because: After one break of Circle or
;; closed Ellipse/Spline/LWPolyline, remaining object retains original entity name but
;; may not be (entlast). But with "heavy" 2D or 3D Polyline, remaining object(s) [on both
;; sides of break if appropriate] get(s) *new* entity name(s) [original(s) is/are lost], and
;; downstream portion from break [if present; upstream otherwise] is always (entlast).
;; Entity-type- and linetype-specific notes:
;; ["2D" in relation to Polylines always refers to "heavy" 2D Polylines.]
;; 1. In closed 2D/LW Polylines, linetype cycle in display does not begin at start/end
;; point (1st vertex, parameter 0), but at 2nd vertex (parameter 1). Routines break objects
;; to conform to that.
;; 2. Routines process 2D/LW Polylines as if linetype generation is enabled, whether
;; or not it is for a given object or in the drawing for new Polylines. To emulate disabled
;; linetype generation, explode Polyline(s) first, and process the resulting Lines/Arcs.
;; 3. 3DPolylines *do not* honor non-continuous linetypes in display. Routines use a
;; segment beginning from start point of closed ones (like Circle, but unlike 2D & LW
;; Polylines), because it's easier; can't match appearance of non-Broken-Up one anyway.
;; 4. Closed Ellipses/Splines with non-continuous linetypes *do not* divide evenly in
;; display, but can have unequal-length dash segment straddling start point (apparently
;; treat cycle as with open-ended objects, not adjusting dash/gap sizes as with Circles/
;; closed Polylines, but adjusting ends); routines regularize that, dividing overall length
;; evenly with adjusted dash/gap sizes, but retain centering of segment around start
;; point characteristic of displayed whole objects.
;; 5. Dot family linetypes display dots at defined-gap spacing for certain objects, equal
;; adjusted spacing for certain [but not all] closed objects, and with peculiarities at ends
;; of some curved objects, in some cases affected by Zoom level. Routines use adjusted
;; equal spacing throughout for all objects.
;;;; SO FAR:
;;;; 1. does not account for different coordinate systems;
;;;; 2. except in Dot family routines, leaves alone the linetype of an object's Layer, or any
;;;; override linetype on the object [e.g., a Line with a short-cycle linetype such as
;;;; HIDDEN2, either through its Layer or as an override, broken up with a long-cycle
;;;; routine such as BU-DASHEDX2, will result in Lines of DashedX2 dash length that
;;;; still have HIDDEN2 linetype, displaying segmented into 6 pieces in that case];
;;;; 3. ignores any linetype scale overrides on selected items, and breaks up into
;;;; segments sized for linetype scale of 1 relative to drawing's LTSCALE setting.
;;;; Possible enhancements to come:
;;;; In linetypes with Dots, what about Plines with width? Insert perpendicular Line with length = Pline width ?
;;;; Overall test for too-shortness before even doing first-cycle break(s)?
;;;; Linetype-generic option to break up according to object's/layer's linetype [& scale?] ?
;; ------------------ Preliminaries and shared sub-routines ------------------
(vl-load-com)
(defun lts (num)
(* (getvar 'ltscale) num)
); end defun - lts
(defun BU-common ()
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); end if
(command)
(command)
(BU-reset)
); end defun - *error*
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(setq
osm (getvar 'osmode)
clay (getvar 'clayer);;;;do this only in families with dots?
blipm (getvar 'blipmode)
); end setq
(setvar 'osmode 0)
(prompt (strcat "To Break Up objects to emulate " BU-lt " linetype,"))
(setq BU-sel (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))))
(setvar 'blipmode 0)
); end defun - BU-common
(defun BU-entlen (obj)
(vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj))
); end defun - BU-entlen
(defun BU-entinfo (/ edata cycleratio); common to all commands
(setq
brkent (ssname BU-sel 0)
unlk (= (cdr (assoc 70 (tblsearch "layer" (cdr (assoc 8 (entget brkent)))))) 0)
;; object is on unlocked Layer
); end setq
(if unlk
(progn - unlocked Layer
(setq
edata (entget brkent)
etype (substr (cdr (assoc 100 (cdr (member (assoc 100 edata) edata)))) 5)
;; *second* 100 value minus "AcDb" prefix, to distinguish Polyline types
closed (vlax-curve-isClosed brkent)
entlen (BU-entlen brkent)
elay (cdr (assoc 8 edata));;;;do this only in families with dots, and remove clay/elay localized variables from no-dot families?
); end setq
(if closed
(progn ; then - closed object
(setq
cycles (fix (+ (/ entlen cycle) 0.5)); rounded up or down
;; change dash and gap sizes to divide equally into overall length:
cycleratio (/ (setq ecycle (/ entlen cycles)) cycle)
edash (if dash (* dash cycleratio)); dash [or longer dash] size for this entity
edash2 (if dash2 (* dash2 cycleratio)); dash2 [if present] size for this entity
egap (* gap cycleratio); gap size for this entity
); end setq
(if (and (wcmatch etype "Polyline,2dPolyline") closed)
;; end/start of a cycle at parameter 1 [2nd vertex], for some reason
(setq seg1len (vlax-curve-getDistAtParam brkent 1))
); end if - LW/2DPoly
); end progn - then - closed object
); end if - closed
(if (/= (substr BU-lt 1 3) "DOT")
;; entities-with-dashes further cycle info, for all except Dot family
(progn ; then
(if (not closed)
(setq ; open-ended object
brklen (- entlen dash)
overage (rem entlen cycle)
cycles
(if (< overage dash)
(1+ (fix (/ brklen cycle)))
(fix (/ brklen cycle))
); end if & cycles
extra (/ (- overage dash) 2); [can be negative]
); end setq - else - open-ended object
); end if - open-ended object
(setq cycles (1- cycles))
;; reduced by 1 for all non-DOT types [1st break cycle not within (repeat cycles...)]
); end progn - then - other than DOT family
); end if - other than DOT family
); end progn - then - on unlocked Layer
); end if - unlocked [no else argument for locked Layer - do nothing]
); end defun - BU-entinfo
(defun BU-brk (obj d1 d2)
(command
"_.break" obj
(vlax-curve-getPointAtDist obj d1)
(vlax-curve-getPointAtDist obj d2)
); end command
); end defun - BU-brk
(defun BU-pt (obj dist)
(command
"_.point"
(vlax-curve-getPointAtDist obj dist)
); end command
); end defun - BU-pt
(defun BU-brkEnd-hvy (obj dist); for partial Gaps at ends of closed 2D/3DPoly only
(command
"_.break" obj
(vlax-curve-getPointAtDist obj dist)
(vlax-curve-getEndPoint obj)
); end command
); end defun - BU-brkEnd-hvy
;; originally used (BU-brk (entlast) edash[2] (BU-entlen (entlast))) in all wrap-Gap
;; conditions in Center/Phantom families, but that break was not happening;
;; (BU-entlen (entlast)) seems to return something invalid. Above works.
(defun BU-reset ()
(setvar 'osmode osm)
(setvar 'blipmode blipm)
(setvar 'clayer clay)
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); end defun - BU-reset
;; ---------------------------------------------- BORDER family ----------------------------------------------
(defun C:BU-BORDER (/ BU-lt dash gap)
(setq
BU-lt "BORDER"
dash (lts 0.5)
gap (lts 0.25)
); setq
(BU-DGDGPG)
); defun
(defun C:BU-BORDER2 (/ BU-lt dash gap)
(setq
BU-lt "BORDER2"
dash (lts 0.25)
gap (lts 0.125)
); setq
(BU-DGDGPG)
); defun
(defun C:BU-BORDERX2 (/ BU-lt dash gap)
(setq
BU-lt "BORDERX2"
dash (lts 1.0)
gap (lts 0.5)
); setq
(BU-DGDGPG)
); defun
(defun BU-DGDGPG ; for linetypes with Dash, Gap, Dash, Gap, Point, Gap [Border family]
(/ *error* cycle cmde osm blipm BU-sel brkent unlk etype closed entlen
elay cycles extra edash egap seg1len ecycle cyc1start wrap brktemp)
(setq cycle (+ dash gap dash gap gap))
(BU-common)
(repeat (sslength BU-sel)
(BU-entinfo)
(if unlk ; set in BU-entinfo if object is on unlocked Layer
(progn ; then - unlocked
(setvar 'clayer elay)
(if closed
(cond ; then - closed object
((= etype "Polyline"); LWPoly 1st cycle starts a long dash past param 1
(BU-brk brkent (+ seg1len edash) (+ seg1len edash egap))
;; 1st break [1st gap] leaves in one piece with same entity name;
(BU-pt brkent (+ edash egap))
(BU-brk brkent edash (+ edash egap egap)); 2nd/3rd gaps
;; 2nd break leaves remainder as (entlast)
); end LWPolyline condition
((= etype "2dPolyline")
(setq cyc1start (rem seg1len ecycle))
;; when (< seg1len ecycle), this will be distance *at* 2nd vertex/param 1
(cond
((>= cyc1start (+ egap edash egap egap))
;; T = 1st dash will wrap around or end at start/end vertex
(setq wrap nil)
(BU-brk brkent (- cyc1start egap edash egap egap) (- cyc1start egap egap edash))
;; leaves 2DPoly downstream remainder as (entlast)
(setq brktemp (entlast))
;; temporary break entity; next BU-brk can't use (entlast) because of added
;; point, and not re-using brkent variable name because (ssdel) at end needs it
(BU-pt brktemp (+ edash egap))
(BU-brk brktemp edash (+ edash egap egap)); 2nd/3rd gaps
); end longer-dash wrap/end condition
((> (+ egap edash egap egap) cyc1start (+ edash egap egap))
;; T = 1st gap will wrap around start/end vertex
(setq wrap "G1")
(BU-brk brkent 0 (- cyc1start egap egap edash)); portion of 1st gap
(setq brktemp (entlast))
(BU-pt brktemp (+ edash egap))
(BU-brk brktemp edash (+ edash egap egap)); 2nd/3rd gaps
); end 1st-gap condition
((>= (+ edash egap egap) cyc1start (+ egap egap))
;; T = 2nd dash will wrap around or end at start/end vertex
(setq wrap "D2")
(BU-pt brkent (- cyc1start egap))
(BU-brk brkent (- cyc1start egap egap) cyc1start); 2nd/3rd gaps
); end 1st-shorter-dash condition
((> (+ egap egap) cyc1start egap)
;; T = 2nd gap will wrap around start/end vertex
(setq wrap "G2")
(BU-pt brkent (- cyc1start egap))
(BU-brk brkent 0 cyc1start); portion of 2nd gap, 3rd gap
); end 2nd-gap condition
((= egap cyc1start)
;; T = point at start/end vertex
(setq wrap "P")
(BU-pt brkent 0)
(BU-brk brkent 0 cyc1start); 3rd gap
); end point condition
((> egap cyc1start); T = 3rd gap will wrap around start/end vertex
(setq wrap "G3")
(BU-brk brkent 0 cyc1start)
); end 3rd-gap condition
); end cond - wrapping of start/end vertex
); end 2DPoly condition
((= etype "3dPolyline")
(BU-brk brkent edash (+ edash egap)); 1st gap
;; 1st break leaves remainder as (entlast)
(setq brktemp (entlast))
(BU-pt brktemp (+ edash egap))
(BU-brk brktemp edash (+ edash egap egap)); 2nd/3rd gaps
); end 3DPolyline condition
((wcmatch etype "Ellipse,Spline")
(BU-brk brkent (/ edash 2) (+ (/ edash 2) egap))
;; 1st break leaves remainder with same entity name
(BU-pt brkent (+ edash egap))
(BU-brk brkent edash (+ edash egap egap)); 2nd/3rd gaps
;; 2nd break leaves remainder as (entlast)
); end Ellipse/Spline condition
(T ; Circle has segment beginning at start point
(BU-brk brkent edash (+ edash egap))
;; 1st break leaves remainder Arc with same entity name
(BU-pt brkent (+ edash egap))
(BU-brk brkent edash (+ edash egap egap)); 2nd/3rd gaps
;; 2nd break leaves remainder as (entlast)
); end none-of-the-above closed-object [Circle] condition
); end cond - then - closed-object entity type check
(progn ; else - open-ended object
(BU-brk brkent (+ extra dash) (+ extra dash gap))
;; leaves remainder of all types as (entlast)
(setq brktemp (entlast))
(BU-pt brktemp (+ dash gap))
(BU-brk brktemp dash (+ dash gap gap)); 2nd/3rd gaps
); end progn - else - open-ended object
); end if [closed check and initial break cycle]
(repeat (if (and closed (= etype "3dPolyline")) (1- cycles) cycles)
;; remaining after prior reduction(s), less special one for closed 3DPoly
(BU-brk (entlast) (if closed edash dash) (if closed (+ edash egap) (+ dash gap)))
(setq brktemp (entlast))
(BU-pt brktemp (if closed (+ edash egap) (+ dash gap)))
(BU-brk brktemp (if closed edash dash) (if closed (+ edash egap egap) (+ dash gap gap)))
); end repeat
(cond ; special end breaking situations ['wrap' variables for 2DPoly, end of 3DPoly]
((and closed (= etype "2dPolyline") (= wrap "G1"))
;; finish 1st gap [end of 1st gap and 2nd/3rd gaps at beginning]
(BU-brkEnd-hvy (entlast) edash)
); end G1 condition
((and closed (= etype "2dPolyline") (= wrap "D2"))
;; 1st gap of wrap-around cycle [2nd/3rd gaps at beginning]
(BU-brk (entlast) edash (+ edash egap))
); end D2 condition
((and closed (= etype "2dPolyline") wrap (wcmatch wrap "G2,P"))
;; 1st gap & finish or all of 2nd of wrap-around cycle [end of 2nd gap & 3rd gap at beginning]
(BU-brk (entlast) edash (+ edash egap)); 1st gap
(BU-brkEnd-hvy (entlast) edash); finish 2nd gap
); end G2 or P condition
((and closed (or (and (= etype "2dPolyline") (= wrap "G3")) (= etype "3dPolyline")))
;; 1st/2nd gaps, point, & finish 3rd gap of wrap-around cycle [end of 3rd gap at beginning]
;; or special last cycle to avoid overshooting end of closed 3DPoly
(BU-brk (entlast) edash (+ edash egap)); 1st gap
(setq brktemp (entlast))
(BU-pt brktemp (+ edash egap))
(BU-brkEnd-hvy brktemp edash); portion of 3rd gap [all of it for 3DPoly] to end
); end G3/closed-3DPoly condition
); end cond - closing points/break(s)
); end progn - then - unlocked
); end if - unlocked Layer [no else argument for locked Layer - do nothing]
(ssdel brkent BU-sel)
); end repeat
(BU-reset)
); end defun - BU-DGDGPG [Border]
;; -------------------------------------------- CENTER family -------------------------------------------------
(defun C:BU-CENTER (/ BU-lt dash dash2 gap)
(setq
BU-lt "CENTER"
dash (lts 1.25)
dash2 (lts 0.25)
gap (lts 0.25)
); setq
(BU-DGD2G)
); defun
(defun C:BU-CENTER2 (/ BU-lt dash dash2 gap)
(setq
BU-lt "CENTER2"
dash (lts 0.625)
;; NOTE: ACAD.lin has 0.75 [= neither half of CENTER's long dash, as in all
;; other ...2 linetypes, nor 5x the gap size, as in CENTER & CENTERX2].
;; This uses ratio consistent with others; to match look of ACAD's definition,
;; if desired, change 0.625 above to 0.75.
dash2 (lts 0.125)
gap (lts 0.125)
); setq
(BU-DGD2G)
); defun
(defun C:BU-CENTERX2 (/ BU-lt dash dash2 gap)
(setq
BU-lt "CENTERX2"
dash (lts 2.5)
dash2 (lts 0.5)
gap (lts 0.5)
); setq
(BU-DGD2G)
); defun
(defun C:BU-CENTERLH (/ BU-lt dash dash2 gap)
;; [This is a custom linetype of ours, like Center but with the longer dash twice as long;
;; = Center-line with Long dash and Hyphen between (cf. CENTERLP in Dashdot family)]
(setq
BU-lt "CENTERLH"
dash (lts 2.5)
dash2 (lts 0.25)
gap (lts 0.25)
); setq
(BU-DGD2G)
); defun
(defun BU-DGD2G ; for linetypes with Dash, Gap, Dash2, Gap [Center family]
(/ cycle *error* cmde osm clay blipm BU-sel brkent unlk etype closed entlen
elay cycles extra edash edash2 egap seg1len ecycle cyc1start wrap)
(setq cycle (+ dash gap dash2 gap))
(BU-common)
(repeat (sslength BU-sel)
(BU-entinfo)
(if unlk ; set in BU-entinfo if object is on unlocked Layer
(progn ; then - unlocked
(if closed
(cond ; then - closed object
((= etype "Polyline"); LWPoly 1st break cycle starts a long dash past param 1
(BU-brk brkent (+ seg1len edash) (+ seg1len edash egap))
;; 1st break [1st gap] leaves in one piece with same entity name;
(BU-brk brkent edash2 (+ edash2 egap)); complete cycle
;; 2nd break leaves remainder as (entlast)
); end LWPolyline condition
((= etype "2dPolyline")
(setq cyc1start (rem seg1len ecycle))
;; when (< seg1len ecycle), this will be distance *at* 2nd vertex/param 1
(cond
((>= cyc1start (+ egap edash2 egap))
;; T = longer dash will wrap around or end at start/end vertex
(setq wrap nil)
(BU-brk brkent (- cyc1start egap edash2 egap) (- cyc1start egap edash2))
;; leaves 2DPoly downstream remainder as (entlast)
(BU-brk (entlast) edash2 (+ edash2 egap)); complete 1st cycle
); end longer-dash wrap/end condition
((> (+ egap edash2 egap) cyc1start (+ egap edash2))
;; T = 1st gap will wrap around start/end vertex
(setq wrap "G1")
(BU-brk brkent 0 (- cyc1start egap edash2))
(BU-brk (entlast) edash2 (+ edash2 egap)); complete 1st cycle
); end 1st-gap condition
((>= (+ egap edash2) cyc1start egap)
;; T = shorter dash will wrap around or end at start/end vertex
(setq wrap "D2")
(BU-brk brkent (- cyc1start egap) cyc1start)
); end shorter-dash condition
((> egap cyc1start); T = 2nd gap will wrap around start/end vertex
(setq wrap "G2")
(BU-brk brkent 0 cyc1start); complete 1st cycle
); end 2nd-gap condition
); end cond - wrapping of start/end vertex
); end 2DPoly condition
((= etype "3dPolyline")
(BU-brk brkent edash (+ edash egap))
;; 1st break leaves remainder as (entlast)
(BU-brk (entlast) edash2 (+ edash2 egap)); complete 1st cycle
); end 3DPolyline condition
((wcmatch etype "Ellipse,Spline")
(BU-brk brkent (/ edash 2) (+ (/ edash 2) egap))
;; 1st break leaves remainder with same entity name
(BU-brk brkent edash2 (+ edash2 egap)); complete 1st cycle
;; 2nd break leaves remainder as (entlast)
); end Ellipse/Spline condition
(T ; Circle has segment beginning at start point
(BU-brk brkent edash (+ edash egap))
;; 1st break leaves remainder Arc with same entity name
(BU-brk brkent edash2 (+ edash2 egap)); complete 1st cycle
;; 2nd break leaves remainder as (entlast)
); end none-of-the-above closed-object [Circle] condition
); end cond - then - closed-object entity type check
(progn ; else - open-ended object
(BU-brk brkent (+ extra dash) (+ extra dash gap))
;; leaves remainder of all types as (entlast)
(BU-brk (entlast) dash2 (+ dash2 gap)); complete 1st cycle
); end progn - else - open-ended object
); end if [closed check and initial break cycle]
(repeat (if (and closed (= etype "3dPolyline")) (1- cycles) cycles)
;; remaining after prior reduction(s), less special one for closed 3DPoly
(BU-brk (entlast) (if closed edash dash) (if closed (+ edash egap) (+ dash gap)))
(BU-brk (entlast) (if closed edash2 dash2) (if closed (+ edash2 egap) (+ dash2 gap)))
); end repeat
(cond ; special end breaking situations ['wrap' variables for 2DPoly]
((and (= etype "2dPolyline") (= wrap "G1"))
;; finish 1st gap [end of 1st gap and 2nd gap at beginning]
(BU-brkEnd-hvy (entlast) edash)
); end G1 condition
((and (= etype "2dPolyline") (= wrap "D2"))
;; 1st gap of wrap-around cycle [2nd gap at beginning]
(BU-brk (entlast) edash (+ edash egap))
); end D2 condition
((and closed (or (and (= etype "2dPolyline") (= wrap "G2")) (= etype "3dPolyline")))
;; 1st gap & finish 2nd of wrap-around cycle [end of 2nd gap at beginning] for 2D,
;; or special last cycle to avoid overshooting end of closed 3DPoly
(BU-brk (entlast) edash (+ edash egap)); 1st gap
(BU-brkEnd-hvy (entlast) edash2); finish 2nd gap
); end G2/closed-3D condition
); end cond - closing break(s)
); end progn - then - unlocked
); end if - unlocked Layer [no else argument for locked Layer - do nothing]
(ssdel brkent BU-sel)
); end repeat
(BU-reset)
); end defun - BU-DGD2G [Center]
;; -------------------------------------------- DASHDOT family --------------------------------------------
(defun C:BU-DASHDOT (/ BU-lt dash gap)
(setq
BU-lt "DASHDOT"
dash (lts 0.5)
gap (lts 0.25)
); setq
(BU-DGPG)
); defun
(defun C:BU-DASHDOT2 (/ BU-lt dash gap)
(setq
BU-lt "DASHDOT2"
dash (lts 0.25)
gap (lts 0.125)
); setq
(BU-DGPG)
); defun
(defun C:BU-DASHDOTX2 (/ BU-lt dash gap)
(setq
BU-lt "DASHDOTX2"
dash (lts 1.0)
gap (lts 0.5)
); setq
(BU-DGPG)
); defun
(defun C:BU-CENTERLP (/ BU-lt dash gap)
;; [This is a custom linetype of ours, like Dashdot but with a much longer dash; =
;; Center-line with Long dash and Point between (cf. CENTERLH in Center family)]
(setq
BU-lt "CENTERLP"
dash (lts 2.5)
gap (lts 0.2)
); setq
(BU-DGPG)
); defun
(defun BU-DGPG ; for linetypes with Dash, Gap, Point, Gap [Dashdot family]
(/ *error* cycle cmde osm blipm BU-sel brkent unlk etype closed entlen
elay cycles extra edash egap seg1len ecycle cyc1start wrap brktemp)
(setq cycle (+ dash gap gap))
(BU-common)
(repeat (sslength BU-sel)
(BU-entinfo)
(if unlk ; set in BU-entinfo if object is on unlocked Layer
(progn ; then - unlocked
(setvar 'clayer elay)
(if closed
(cond ; then - closed object
((= etype "Polyline"); LWPoly 1st cycle starts a dash past param 1
;; point first, then break both gaps; do twice to get remainder to be entlast
(BU-pt brkent (+ seg1len edash egap))
(BU-brk brkent (+ seg1len edash) (+ seg1len edash egap egap)); both gaps around point
;; 1st break [1st gap] leaves in one piece with same entity name;
(BU-pt brkent (+ edash egap))
(BU-brk brkent edash (+ edash egap egap)); both gaps
;; 2nd break leaves remainder as (entlast)
(setq cycles (1- cycles))
); end LWPolyline condition
((= etype "2dPolyline")
(setq cyc1start (rem seg1len ecycle))
;; when (< seg1len ecycle), this will be distance *at* 2nd vertex/param 1
(cond
((>= cyc1start (+ egap egap))
;; T = dash will wrap around or end at start/end vertex
(setq wrap nil)
(BU-pt brkent (- cyc1start egap))
(BU-brk brkent (- cyc1start egap egap) cyc1start); both gaps
;; leaves 2DPoly downstream remainder as (entlast)
); end dash wrap/end condition
((> (+ egap egap) cyc1start egap)
;; T = 1st gap will wrap around start/end vertex
(setq wrap "G1")
(BU-pt brkent (- cyc1start egap))
(BU-brk brkent 0 cyc1start); portion of 1st gap, & 2nd gap
); end 1st-gap condition
((= egap cyc1start)
;; T = point at start/end vertex
(setq wrap "P")
(BU-pt brkent 0)
(BU-brk brkent 0 cyc1start); 2nd gap
); end point condition
((> egap cyc1start); T = 2nd gap will wrap around start/end vertex
(setq wrap "G2")
(BU-brk brkent 0 cyc1start)
); end 2nd-gap condition
); end cond - wrapping of start/end vertex
); end 2DPoly condition
((= etype "3dPolyline")
(BU-pt brkent (+ edash egap))
(BU-brk brkent edash (+ edash egap egap)); both gaps
;; 1st break leaves remainder as (entlast)
(setq cycles (1- cycles)); for special end situation
); end 3DPolyline condition
((wcmatch etype "Ellipse,Spline"); dash straddles start/end point
(BU-pt brkent (+ (/ edash 2) egap))
(BU-brk brkent (/ edash 2) (+ (/ edash 2) egap egap))
;; 1st break leaves remainder with same entity name
(BU-pt brkent (+ edash egap));;;; if long enough?
(BU-brk brkent edash (+ edash egap egap)); both gaps
;; 2nd break leaves remainder as (entlast)
(setq cycles (1- cycles))
); end Ellipse/Spline condition
(T ; Circle has segment beginning at start point
(repeat 2
(BU-pt brkent (+ edash egap))
(BU-brk brkent edash (+ edash egap egap)); both gaps
;; 1st break leaves remainder Arc with same entity name
;; 2nd break leaves remainder as (entlast)
); end repeat
(setq cycles (1- cycles))
); end none-of-the-above closed-object [Circle] condition
); end cond - then - closed-object entity type check
(progn ; else - open-ended object
(BU-pt brkent (+ extra dash gap))
(BU-brk brkent (+ extra dash) (+ extra dash gap gap)); both gaps
;; leaves remainder of all types as (entlast)
); end progn - else - open-ended object
); end if [closed check and initial break cycle(s)]
(repeat cycles ; remaining after prior reduction(s)
;; already did 2 for closed LWPoly/Ell/Spl/Circle; not for open things or 2D/3DPoly
(setq brktemp (entlast))
;; temporary break entity; next BU-brk can't use (entlast) because of added
;; point, and not re-using brkent variable name because (ssdel) at end needs it
(BU-pt brktemp (if closed (+ edash egap) (+ dash gap)))
(BU-brk brktemp (if closed edash dash) (if closed (+ edash egap egap) (+ dash gap gap)))
); end repeat
(cond ; special end breaking situations ['wrap' variables for 2DPoly, end of 3DPoly]
((and closed (= etype "2dPolyline") wrap (wcmatch wrap "G1,P"))
;; finish or all of 1st gap [possible end of 1st gap, point and 2nd gap at beginning]
(BU-brkEnd-hvy (entlast) edash)
); end G1/P condition
((and closed (or (and (= etype "2dPolyline") (= wrap "G2")) (= etype "3dPolyline")))
;; 1st gap, point, & finish 2nd gap of wrap-around cycle [end of 2nrd gap at beginning]
;; or special last cycle to avoid overshooting end of closed 3DPoly
(setq brktemp (entlast))
(BU-pt brktemp (+ edash egap))
(BU-brkEnd-hvy brktemp edash); 1st & portion of 2nd gap [all of it for 3DPoly] to end
); end G2/closed-3DPoly condition
); end cond - closing points/break(s)
); end progn - then - unlocked
); end if - unlocked Layer [no else argument for locked Layer - do nothing]
(ssdel brkent BU-sel)
); end repeat
(BU-reset)
); end defun - BU-DGPG [Dashdot]
;; -------------------------------- DASHED & HIDDEN families --------------------------------
(defun C:BU-DASHED (/ BU-lt dash gap)
(setq
BU-lt "DASHED"
dash (lts 0.5)
gap (lts 0.25)
); setq
(BU-DG)
); defun
(defun C:BU-DASHED2 (/ BU-lt dash gap)
(setq
BU-lt "DASHED2"
dash (lts 0.25)
gap (lts 0.125)
); setq
(BU-DG)
); defun
(defun C:BU-DASHEDX2 (/ BU-lt dash gap)
(setq
BU-lt "DASHEDX2"
dash (lts 1.0)
gap (lts 0.5)
); setq
(BU-DG)
); defun
(defun C:BU-HIDDEN (/ BU-lt dash gap)
(setq
BU-lt "HIDDEN"
dash (lts 0.125)
gap (lts 0.125)
); setq
(BU-DG)
); defun
(defun C:BU-DOTTY (/ BU-lt dash gap)
(setq
BU-lt "HIDDEN"
dash (lts 0.0125)
gap (lts 0.125)
); setq
(BU-DG)
); defun
(defun C:BU-HIDDEN2 (/ BU-lt dash gap)
(setq
BU-lt "HIDDEN2"
dash (lts 0.125)
gap (lts 0.0625)
); setq
(BU-DG)
); defun
(defun C:BU-HIDDENX2 (/ BU-lt dash gap)
(setq
BU-lt "HIDDENX2"
dash (lts 0.5)
gap (lts 0.25)
); setq
(BU-DG)
); defun
(defun BU-DG ; for linetypes with 1 Dash and 1 Gap [Dashed/Hidden families]
(/ *error* cycle cmde osm clay blipm BU-sel brkent unlk etype closed
entlen elay cycles extra ecycle edash egap seg1len cyc1start gwrap)
(setq cycle (+ dash gap))
(BU-common)
(repeat (sslength BU-sel)
(BU-entinfo)
(if unlk ; set in BU-entinfo if object is on unlocked Layer
(progn ; then - unlocked
(if closed
(cond ; then - closed object
((wcmatch etype "Polyline,2dPolyline")
(setq
cyc1start (rem seg1len ecycle)
;; when (< seg1len ecycle), this will be *at* 2nd vertex/param 1
gwrap (> egap cyc1start); T = gap will wrap around start/end vertex
); end setq
(BU-brk brkent cyc1start
;; 1st break leaves remainder LWPoly with same entity name, 2DPoly as (entlast)
(if gwrap ; can't break from *before* start point
0 ; just back to beginning
(- cyc1start egap)
); end if
); end BU-brk
(if (= etype "Polyline"); = LWPolyline
(progn ; then
(BU-brk brkent edash ecycle)
;; 2nd break leaves remainder LWpoly as (entlast)
(setq cycles (1- cycles)); reduce again for 2nd break, LWPoly only
); end progn - then - LWPoly
); end if - LWPoly [no else if 2DPoly]
); end LW/2DPoly condition
((= etype "3dPolyline")
(BU-brk brkent edash ecycle)
;; 1st break leaves remainder as (entlast)
(setq cycles (1- cycles)); reduce for special end condition
); end 3DPolyline condition
((wcmatch etype "Ellipse,Spline")
(BU-brk brkent (/ edash 2) (- ecycle (/ edash 2)))
;; 1st break leaves remainder with same entity name
(BU-brk brkent edash ecycle)
;; 2nd break leaves remainder as (entlast)
(setq cycles (1- cycles)); reduce again for 2nd break
); end Ellipse/Spline condition
(T ; Circle has segment beginning at start point
(BU-brk brkent edash ecycle)
;; 1st break leaves remainder Arc with same entity name
(BU-brk brkent edash ecycle)
;; 2nd break leaves remainder as (entlast)
(setq cycles (1- cycles)); reduce again for 2nd break
); end none-of-the-above closed-object [Circle] condition
); end cond - then - closed-object entity type check
(BU-brk brkent (+ extra dash) (+ extra cycle)) ; else - open-ended object
;; leaves remainder as (entlast)
); end if [closed check and initial break(s)]
(repeat cycles ; remaining after reductions above
(BU-brk (entlast) (if closed edash dash) (if closed ecycle cycle))
); end repeat
(if ; special end condition
(and closed (or gwrap (= etype "3dPolyline")))
(BU-brk (entlast) edash (BU-entlen (entlast)))
;; take out last part of closed LW/2D/3DPoly to original start/end vertex
); end if - special end condition
); end progn - then - unlocked
); end if - unlocked Layer [no else argument for locked Layer - do nothing]
(ssdel brkent BU-sel)
); end repeat
(BU-reset)
); end defun - BU-DG [Dashed/Hidden]
;; -------------------------------------------- DIVIDE family --------------------------------------------
(defun C:BU-DIVIDE (/ BU-lt dash gap)
(setq
BU-lt "DIVIDE"
dash (lts 0.5)
gap (lts 0.25)
); setq
(BU-DGPGPG)
); defun
(defun C:BU-DIVIDE2 (/ BU-lt dash gap)
(setq
BU-lt "DIVIDE2"
dash (lts 0.25)
gap (lts 0.125)
); setq
(BU-DGPGPG)
); defun
(defun C:BU-DIVIDEX2 (/ BU-lt dash gap)
(setq
BU-lt "DIVIDEX2"
dash (lts 1.0)
gap (lts 0.5)
); setq
(BU-DGPGPG)
); defun
(defun C:BU-PROPERTY (/ BU-lt dash gap)
;; [This is a custom linetype of ours, like Divide but with a much longer dash]
(setq
BU-lt "PROPERTY"
dash (lts 6)
gap (lts 0.25)
); setq
(BU-DGPGPG)
); defun
(defun BU-DGPGPG ; for linetypes with Dash, Gap, Point, Gap, Point, Gap [Divide family]
(/ *error* cycle cmde osm blipm BU-sel brkent unlk etype closed entlen
elay cycles extra edash egap seg1len ecycle cyc1start wrap brktemp)
(setq cycle (+ dash gap gap gap))
(BU-common)
(repeat (sslength BU-sel)
(BU-entinfo)
(if unlk ; set in BU-entinfo if object is on unlocked Layer
(progn ; then - unlocked
(setvar 'clayer elay)
(if closed
(cond ; then - closed object
((= etype "Polyline"); LWPoly 1st cycle starts a long dash past param 1
(BU-pt brkent (+ seg1len edash egap)); 1st point
(BU-pt brkent (+ seg1len edash egap egap)); 2nd point
(BU-brk brkent (+ seg1len edash) (+ seg1len edash egap egap egap)); all gaps
;; 1st break leaves in one piece with same entity name;
(BU-pt brkent (+ edash egap)); 1st point;;;; if long enough?
(BU-pt brkent (+ edash egap egap)); 2nd point
(BU-brk brkent edash (+ edash egap egap egap)); all gaps
;; 2nd break leaves remainder as (entlast)
(setq cycles (1- cycles))
); end LWPolyline condition
((= etype "2dPolyline")
(setq cyc1start (rem seg1len ecycle))
;; when (< seg1len ecycle), this will be distance *at* 2nd vertex/param 1
(cond
((>= cyc1start (+ egap egap egap))
;; T = dash will wrap around or end at start/end vertex
(setq wrap nil)
(BU-pt brkent (- cyc1start egap egap egap)); 1st point
(BU-pt brkent (- cyc1start egap egap)); 2nd point
(BU-brk brkent (- cyc1start egap egap egap) cyc1start); all gaps
;; leaves 2DPoly downstream remainder as (entlast)
); end dash wrap/end condition
((> (+ egap egap egap) cyc1start (+ egap egap))
;; T = 1st gap will wrap around start/end vertex
(setq wrap "G1")
(BU-pt brkent (- cyc1start egap egap)); 1st point
(BU-pt brkent (- cyc1start egap)); 2nd point
(BU-brk brkent 0 cyc1start); end of 1st gap, & 2nd/3rd gaps
); end 1st-gap condition
((= (+ egap egap) cyc1start)
;; T = 1st point at start/end vertex
(setq wrap "P1")
(BU-pt brkent 0); 1st point
(BU-pt brkent (- cyc1start egap)); 2nd point
(BU-brk brkent 0 cyc1start); 2nd/3rd gaps
); end 1st-point condition
((> (+ egap egap) cyc1start egap)
;; T = 2nd gap will wrap around start/end vertex
(setq wrap "G2")
(BU-pt brkent (- cyc1start egap)); 2nd point
(BU-brk brkent 0 cyc1start); end of 2nd gap, & 3rd gap
); end 2nd-gap condition
((= egap cyc1start)
;; T = 2nd point at start/end vertex
(setq wrap "P2")
(BU-pt brkent 0); 2nd point
(BU-brk brkent 0 cyc1start); 3rd gap
); end 2nd-point condition
((> egap cyc1start); T = 3rd gap will wrap around start/end vertex
(setq wrap "G3")
(BU-brk brkent 0 cyc1start); end of 3rd gap
); end 3rd-gap condition
); end cond - wrapping of start/end vertex
); end 2DPoly condition
((= etype "3dPolyline")
(BU-pt brkent (+ edash egap)); 1st point
(BU-pt brkent (+ edash egap egap)); 2nd point
(BU-brk brkent edash (+ edash egap egap egap)); all gaps
;; leaves remainder as (entlast)
(setq cycles (1- cycles)); for special end condition
); end 3DPolyline condition
((wcmatch etype "Ellipse,Spline")
(BU-pt brkent (+ (/ edash 2) egap)); 1st point
(BU-pt brkent (+ (/ edash 2) egap egap)); 2nd point
(BU-brk brkent (/ edash 2) (+ (/ edash 2) egap egap egap)); all gaps
;; leaves remainder with same entity name
(BU-pt brkent (+ edash egap)); 1st point
(BU-pt brkent (+ edash egap egap)); 2nd point
(BU-brk brkent edash (+ edash egap egap egap)); all gaps
;; 2nd break leaves remainder as (entlast)
(setq cycles (1- cycles)); did 2 cycles to get to (entlast)
); end Ellipse/Spline condition
(T ; Circle has segment beginning at start point
(BU-pt brkent (+ edash egap)); 1st point
(BU-pt brkent (+ edash egap egap)); 2nd point
(BU-brk brkent edash (+ edash egap egap egap)); all gaps
;; 1st break leaves remainder Arc with same entity name
(BU-pt brkent (+ edash egap)); 1st point
(BU-pt brkent (+ edash egap egap)); 2nd point
(BU-brk brkent edash (+ edash egap egap egap)); all gaps
;; 2nd break leaves remainder as (entlast)
(setq cycles (1- cycles)); did 2 cycles to get to (entlast)
); end none-of-the-above closed-object [Circle] condition
); end cond - then - closed-object entity type check
(progn ; else - open-ended object
(BU-pt brkent (+ extra dash gap)); 1st point
(BU-pt brkent (+ extra dash gap gap)); 2nd point
(BU-brk brkent (+ extra dash) (+ extra dash gap gap gap)); all gaps
;; leaves remainder of all types as (entlast)
); end progn - else - open-ended object
); end if [closed check and initial break cycle]
(repeat cycles
;; remaining after prior reduction(s)
(setq brktemp (entlast))
;; temporary break entity; next BU-brk can't use (entlast) because of added
;; points, and not re-using brkent variable name because (ssdel) at end needs it
(BU-pt brktemp (if closed (+ edash egap) (+ dash gap))); 1st point
(BU-pt brktemp (if closed (+ edash egap egap) (+ dash gap gap))); 2nd point
(BU-brk brktemp; all gaps
(if closed edash dash)
(if closed (+ edash egap egap egap) (+ dash gap gap gap))
); end BU-brk
); end repeat
(cond ; special end breaking situations ['wrap' variables for 2DPoly, end of 3DPoly]
((and closed (= etype "2dPolyline") wrap (wcmatch wrap "G1,P1"))
;; finish or all of 1st gap [possible end of 1st gap, points and 2nd/3rd gaps at beginning]
(BU-brkEnd-hvy (entlast) edash)
); end G1/P1 condition
((and closed (= etype "2dPolyline") wrap (wcmatch wrap "G2,P2"))
;; 1st gap, 1st point, finish or all of 2nd gap [possible end of 2nd gap, 2nd point, 3rd gap at beginning]
(setq brktemp (entlast))
(BU-pt brktemp (+ edash egap)); 1st point
(BU-brkEnd-hvy brktemp edash); gaps
); end G2/P2 condition
((and closed (or (and (= etype "2dPolyline") (= wrap "G3")) (= etype "3dPolyline")))
;; 1st/2nd gaps, points, & finish 3rd gap of wrap-around cycle [end of 3rd gap at beginning]
;; or special last cycle to avoid overshooting end of closed 3DPoly
(setq brktemp (entlast))
(BU-pt brktemp (+ edash gap)); 1st point
(BU-pt brktemp (+ edash gap gap)); 2nd point
(BU-brkEnd-hvy brktemp edash); 1st/2nd/part of 3rd gap [all of it for 3DPoly] to end
); end G3/closed-3DPoly condition
); end cond - closing points/break(s)
); end progn - then - unlocked
); end if - unlocked Layer [no else argument for locked Layer - do nothing]
(ssdel brkent BU-sel)
); end repeat
(BU-reset)
); end defun - BU-DGPGPG [Divide]
;; ---------------------------------------------- DOT family ----------------------------------------------
(defun C:BU-DOT (/ BU-lt gap)
(setq
BU-lt "DOT"
gap (lts 0.25)
); setq
(BU-PG)
); defun
(defun C:BU-DOT2 (/ BU-lt gap)
(setq
BU-lt "DOT2"
gap (lts 0.125)
); setq
(BU-PG)
); defun
(defun C:BU-DOTX2 (/ BU-lt gap)
(setq
BU-lt "DOTX2"
gap (lts 0.5)
); setq
(BU-PG)
); defun
(defun BU-PG ; for linetypes with 1 Point and 1 Gap [Dot family]
(/ *error* cycle cmde osm clay blipm BU-sel brkent unlk etype closed entlen elay cycles inc)
(setq cycle gap)
(BU-common)
(repeat (sslength BU-sel)
(BU-entinfo)
(if unlk ; set in BU-entinfo if object is on unlocked Layer
(progn ; then - unlocked
(setvar 'clayer elay)
(if (not closed)
(progn
(setq cycles (fix (+ (/ entlen cycle) 0.5)))
(command ; add Points at ends of open objects
"_.point" (vlax-curve-getStartPoint brkent)
"_.point" (vlax-curve-getEndPoint brkent)
); end command
); end progn
); end if - open-ended object
(if (and (wcmatch etype "Polyline,2dPolyline") closed)
(progn ; then - closed 2D/LWPoly only
(setq inc 0)
(repeat cycles
(command
"_.point"
(vlax-curve-getPointAtDist
brkent
(+ (rem seg1len egap) (* inc egap))
;; to put Point at vertex 2/param 1
); end getPoint
); end command
(setq inc (1+ inc))
); end repeat
); end progn - then - closed 2D/LWPoly
(command "_.divide" brkent cycles); else - all others
); end if - closed 2D/LWPoly
(entdel brkent)
); end progn - then - unlocked
); end if - unlocked Layer [no else argument for locked Layer - do nothing]
(ssdel brkent BU-sel)
); end repeat
(BU-reset)
); end defun - BU-PG [Dot]
;; ----------------------- HIDDEN family [see BU-DG under DASHED] -----------------------
;; ------------------------------------------ PHANTOM family ------------------------------------------
(defun C:BU-PHANTOM (/ BU-lt dash dash2 gap)
(setq
BU-lt "PHANTOM"
dash (lts 1.25)
dash2 (lts 0.25)
gap (lts 0.25)
); setq
(BU-DGD2GD2G)
); defun
(defun C:BU-PHANTOM2 (/ BU-lt dash dash2 gap)
(setq
BU-lt "PHANTOM2"
dash (lts 0.625)
dash2 (lts 0.125)
gap (lts 0.125)
); setq
(BU-DGD2GD2G)
); defun
(defun C:BU-PHANTOMX2 (/ BU-lt dash dash2 gap)
(setq
BU-lt "PHANTOMX2"
dash (lts 2.5)
dash2 (lts 0.5)
gap (lts 0.5)
); setq
(BU-DGD2GD2G)
); defun
(defun BU-DGD2GD2G ; for linetypes with Dash, Gap, Dash2, Gap, Dash2, Gap [Phantom family]
(/ *error* cycle cmde osm clay blipm BU-sel brkent unlk etype closed entlen
elay cycles extra edash edash2 egap seg1len ecycle cyc1start wrap)
(setq cycle (+ dash gap dash2 gap dash2 gap))
(BU-common)
(repeat (sslength BU-sel)
(BU-entinfo)
(if unlk ; set in BU-entinfo if object is on unlocked Layer
(progn ; then - unlocked
(if closed
(cond ; then - closed object
((= etype "Polyline"); LWPoly 1st cycle starts a long dash past param 1
(BU-brk brkent (+ seg1len edash) (+ seg1len edash egap))
;; 1st break [1st gap] leaves in one piece with same entity name;
(BU-brk brkent edash2 (+ edash2 egap)); 2nd gap
;; 2nd break leaves remainder as (entlast)
(BU-brk (entlast) edash2 (+ edash2 egap)); complete 1st cycle
); end LWPolyline condition
((= etype "2dPolyline")
(setq cyc1start (rem seg1len ecycle))
;; when (< seg1len ecycle), this will be distance *at* 2nd vertex/param 1
(cond
((>= cyc1start (+ egap edash2 egap edash2 egap))
;; T = longer dash will wrap around or end at start/end vertex
(setq wrap nil)
(BU-brk brkent (- cyc1start egap edash2 egap edash2 egap) (- cyc1start egap edash2 egap edash2))
;; leaves 2DPoly downstream remainder as (entlast)
(BU-brk (entlast) edash2 (+ edash2 egap)); 2nd gap
(BU-brk (entlast) edash2 (+ edash2 egap)); complete 1st cycle
); end longer-dash wrap/end condition
((> (+ egap edash2 egap edash2 egap) cyc1start (+ egap edash2 egap edash2))
;; T = 1st gap will wrap around start/end vertex
(setq wrap "G1")
(BU-brk brkent 0 (- cyc1start egap edash2 egap edash2));portion of 1st gap
(BU-brk (entlast) edash2 (+ edash2 egap)); 2nd gap
(BU-brk (entlast) edash2 (+ edash2 egap)); complete 1st cycle
); end 1st-gap condition
((>= (+ egap edash2 egap edash2) cyc1start (+ egap edash2 egap))
;; T = 1st shorter dash will wrap around or end at start/end vertex
(setq wrap "D2")
(BU-brk brkent (- cyc1start egap edash2 egap) (- cyc1start egap edash2)); 2nd gap
(BU-brk (entlast) edash2 (+ edash2 egap)); complete 1st cycle
); end 1st-shorter-dash condition
((> (+ egap edash2 egap) cyc1start (+ egap edash2))
;; T = 2nd gap will wrap around start/end vertex
(setq wrap "G2")
(BU-brk brkent 0 (- cyc1start egap edash2)); portion of 2nd gap
(BU-brk (entlast) edash2 (+ edash2 egap)); complete 1st cycle
); end 2nd-gap condition
((>= (+ egap edash2) cyc1start egap)
;; T = 2nd shorter dash will wrap around or end at start/end vertex
(setq wrap "D3")
(BU-brk brkent (- cyc1start egap) cyc1start); 3rd gap
); end 1st-shorter-dash condition
((> egap cyc1start); T = 3rd gap will wrap around start/end vertex
(setq wrap "G3")
(BU-brk brkent 0 cyc1start)
); end 3rd-gap condition
); end cond - wrapping of start/end vertex
); end 2DPoly condition
((= etype "3dPolyline")
(BU-brk brkent edash (+ edash egap))
;; 1st break leaves remainder as (entlast)
(BU-brk (entlast) edash2 (+ edash2 egap)); 2nd gap
(BU-brk (entlast) edash2 (+ edash2 egap)); complete 1st cycle
); end 3DPolyline condition
((wcmatch etype "Ellipse,Spline")
(BU-brk brkent (/ edash 2) (+ (/ edash 2) egap))
;; 1st break leaves remainder with same entity name
(BU-brk brkent edash2 (+ edash2 egap))
;; 2nd break leaves remainder as (entlast)
(BU-brk (entlast) edash2 (+ edash2 egap)); complete 1st cycle
); end Ellipse/Spline condition
(T ; Circle has segment beginning at start point
(BU-brk brkent edash (+ edash egap))
;; 1st break leaves remainder Arc with same entity name
(BU-brk brkent edash2 (+ edash2 egap))
;; 2nd break leaves remainder as (entlast)
(BU-brk (entlast) edash2 (+ edash2 egap)); complete 1st cycle
); end none-of-the-above closed-object [Circle] condition
); end cond - then - closed-object entity type check
(progn ; else - open-ended object
(BU-brk brkent (+ extra dash) (+ extra dash gap))
;; leaves remainder of all types as (entlast)
(BU-brk (entlast) dash2 (+ dash2 gap)); 2nd gap
(BU-brk (entlast) dash2 (+ dash2 gap)); complete cycle
); end progn - else - open-ended object
); end if [closed check and initial break cycle]
(repeat (if (and closed (= etype "3dPolyline")) (1- cycles) cycles)
;; remaining after prior reduction(s), less special one for closed 3DPoly
(BU-brk (entlast) (if closed edash dash) (if closed (+ edash egap) (+ dash gap)))
(BU-brk (entlast) (if closed edash2 dash2) (if closed (+ edash2 egap) (+ dash2 gap)))
(BU-brk (entlast) (if closed edash2 dash2) (if closed (+ edash2 egap) (+ dash2 gap)))
); end repeat
(cond ; special end breaking situations ['wrap' variables for 2DPoly]
((and (= etype "2dPolyline") (= wrap "G1"))
;; finish 1st gap [end of 1st gap and 2nd/3rd gaps at beginning]
(BU-brkEnd-hvy (entlast) edash)
); end G1 condition
((and (= etype "2dPolyline") (= wrap "D2"))
;; 1st gap of wrap-around cycle [2nd/3rd gaps at beginning]
(BU-brk (entlast) edash (+ edash egap))
); end D2 condition
((and (= etype "2dPolyline") (= wrap "G2"))
;; 1st gap & finish 2nd of wrap-around cycle [end of 2nd gap & 3rd gap at beginning]
(BU-brk (entlast) edash (+ edash egap)); 1st gap
(BU-brkEnd-hvy (entlast) edash2); finish 2nd gap
); end G2 condition
((and (= etype "2dPolyline") (= wrap "D3"))
;; 1st/2nd gaps of wrap-around cycle [3rd gap at beginning]
(BU-brk (entlast) edash (+ edash egap)); 1st gap
(BU-brk (entlast) edash2 (+ edash2 egap)); 2nd gap
); end D3 condition
((and closed (or (and (= etype "2dPolyline") (= wrap "G3")) (= etype "3dPolyline")))
;; 1st/2nd gaps & finish 3rd of wrap-around cycle [end of 3rd gap at beginning]
;; or special last cycle to avoid overshooting end of closed 3DPoly
(BU-brk (entlast) edash (+ edash egap)); 1st gap
(BU-brk (entlast) edash2 (+ edash2 egap)); 2nd gap
(BU-brkEnd-hvy (entlast) edash2); portion of 3rd gap [all of it for 3DPoly] to end
); end G3/closed-3DPoly condition
); end cond - closing break(s)
); end progn - then - unlocked
); end if - unlocked Layer [no else argument for locked Layer - do nothing]
(ssdel brkent BU-sel)
); end repeat
(BU-reset)
); end defun - BU-DGD2GD2G [Phantom]
; ------------------------------------------------------------------------
(prompt "\nType BU- followed by linetype name to Break Up into short entities and gaps to emulate that linetype.")
(princ)
Strip formatting from MText (configurable) Command: SMTEdit
;;;; 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 <mtext string> (list "f" "O" "U"))
;; Or a quoted list:
;; (StripFormat <mtext string> '("f" "O" "U"))
;; Or a string:
;; (StripFormat <mtext string> "fOU")
;; Remove all formatting except Overline and Underline.
;; (StripFormat <mtext string> (list "*" "^O" "^U"))
;; Or a quoted list:
;; (StripFormat <mtext string> '("*" "^O" "^U"))
;; Or a string:
;; (StripFormat <mtext string> "*^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 "<L" (substr (rtos (getvar "CDATE") 2 8) 14) ">"))
(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)