;;;; StripMtext Version 5.0c for AutoCAD 2000 and above ;;;; Removes embedded Mtext formatting ;;;; ;;;; Copyright© Steve Doman and Joe Burke 2010 ;;;; ;;;; The authors grant permission to use, copy, and modify this routine ;;;; for personal use only and for the use of other AutoCAD users within ;;;; your organization. Selling, modifying, or exchanging this software ;;;; for a fee, or incorporation within a commercial software product, is ;;;; expressly prohibited. All other rights are reserved by the authors. ;;;; ;;;; Please send comments, wish lists, or bug reports to: ;;;; cadabyss@gmail.com or lowercase@hawaii.rr.com ;;;; ;;;; Look for new stable releases at: ;;;; http://cadabyss.wordpress.com/ ;;;; ;;;; More information may also be found at: ;;;; http://www.theswamp.org/ ;;;; Subforum: "Show your stuff", Subject: "StripMtext v5" ;;;; ;;;; ;;;; DESCRIPTION ;;;; ;;;; This AutoLISP program creates a command "StripMtext" (shortcut ;;;; "SMT"), that will enable the user to quickly remove selected ;;;; formatting codes from selected Mtext, Mleaders, Dimensions, Tables, ;;;; and Multiline Attributes. ;;;; ;;;; StripMtext can remove the following types of formatting: ;;;; ;;;; Alignment ;;;; Background Masks ;;;; Color ;;;; Columns ;;;; Fields (converts fields to static text) ;;;; Font ;;;; Height ;;;; Line Feed (newline, line break, carriage return) ;;;; Non-breaking Space ;;;; Obliquing ;;;; Overline ;;;; Paragraph (embedded justification, line spacing, indents) ;;;; Stacking ;;;; Tabs ;;;; Tracking ;;;; Underline ;;;; Width ;;;; ;;;; ;;;; CAVEATS ;;;; ;;;; Acad Versions - ;;;; If your version of AutoCAD does not support a formatting code ;;;; introduced in a latter year, that format will be disabled and appear ;;;; grayed-out in the dialog. ;;;; ;;;; Locked Table Cells - ;;;; If locked cells are found in a table while processing, they will be ;;;; skipped and the message "Some table cells are locked" will be ;;;; printed at the commnand prompt. This is by design and intended to ;;;; protect cell contents from accidental stripping. ;;;; ;;;; Reformatting Alignment - ;;;; It has been observed that after running StripMtext to remove ;;;; alignment formats from dimension objects, AutoCAD will sometimes ;;;; automatically add back the alignment format ("\\A1;"). AutoCAD's ;;;; apparent reformatting behavior makes it appear that there is a bug ;;;; in this routine. However tests indicate that the dimension mtext ;;;; string was indeed stripped correctly but AutoCAD, for what ever ;;;; reason, put it back. A similar situation occurs with Multiline ;;;; Attributes. ;;;; ;;;; Reformatting Fonts - ;;;; AutoCAD will automatically add back font formatting around ;;;; certain symbols characters after stripping, e.g. Isocpeur font ;;;; is automatically reapplied to the centerline symbol. ;;;; ;;;; Dimension Fractions - ;;;; StripMtext does not unstack fractions that are a part of the displayed ;;;; measurement value, i.e. "<>". It will remove any formatting ;;;; applied before, to, and after the measurement value. ;;;; ;;;; Fields Updating - ;;;; StripMtext uses the UPDATEFIELD command prior to removing formatting ;;;; from Fields embedded in Mtext and Multiline Attributes. ;;;; ;;;; ;;;; HOW TO LOAD (for the newbie) ;;;; ;;;; There are a few different methods to load an AutoLISP program. ;;;; Perhaps the easiest method is to type APPLOAD at the command prompt. ;;;; Then browse to the location of this file. Highlight the file name, ;;;; and then hit "Load". Hit the "Close" button to dismiss the APPLOAD ;;;; dialog. This procedure loads the program into the current drawing. ;;;; ;;;; To automatically load this file each time you open a drawing, add ;;;; the filename to APPLOAD's Startup Suite: APPLOAD > Contents > Add > ;;;; Browse to file > Load. ;;;; ;;;; ;;;; HOW TO USE ;;;; ;;;; (1) When you first start StripMtext, you will be asked to select ;;;; objects. When you have finished selecting, hit ENTER. ;;;; ;;;; Alternatively, if you pre-select (grip) objects and then issue ;;;; the StripMtext command, the pre-selected objects will be ;;;; accepted and the routine will move on to the next step without ;;;; further prompting. This so called "noun/verb" selection ;;;; behavior is dependent on the system variable PICKFIRST being set ;;;; to 1. ;;;; ;;;; With either selection method you choose to use, StripMtext will ;;;; remove from your selection any unsupported objects and any ;;;; objects that reside on locked layers. ;;;; ;;;; (2) Next, a dialog window will appear that displays a list of the ;;;; names of each formatting code with a corresponding check box. ;;;; Turn on the check box for each type of formatting you wish to ;;;; remove. You can quickly turn on or off all check boxes by using ;;;; the "Select All" or "Clear All" buttons. ;;;; ;;;; (3) If you would like StripMtext to save your checked marked ;;;; settings as a your default, turn on the "Remember Settings" ;;;; check box. StripMtext will store your default settings in the ;;;; Windows Registry. ;;;; ;;;; (4) Hit the "Ok" button to proceed with removing formats or the ;;;; "Cancel" button to exit without making changes. ;;;; ;;;; (5) Enjoy! ;;;; ;;;; ;;;; You are encouraged to spend a few minutes experimenting with ;;;; different format removal settings using a temporary drawing. If for ;;;; any reason you do not like the results, you can immediately issue an ;;;; UNDO command to restore your drawing to its prior condition. ;;;; ;;;; ;;;; HOW TO USE BY SCRIPT OR AUTOLISP ;;;; ;;;; When the StripMtext file loads into the drawing, it purposely ;;;; exposes the StripMtext function for your use during scripts and/or ;;;; your own AutoLISP routines. ;;;; ;;;; This function by-passes the user interface and therefore is an ;;;; excellent method to remove formatting from a batch of drawings ;;;; without user input, or to use in your own custom commands where you ;;;; need to remove Mtext formatting. ;;;; ;;;; To do this, your script or AutoLISP routine must load the StripMtext ;;;; file into the current drawing and then call StripMtext with valid ;;;; arguments. ;;;; ;;;; Syntax: ;;;; ;;;; (StripMtext SS Formats) ;;;; ;;;; SS A pickset containing entities to process. StripMtext will ;;;; ignore entities in the pickset that it does not support. ;;;; ;;;; Supported entities ;;;; ------------------ ;;;; Dimensions ;;;; Mleaders ;;;; Mtext ;;;; Multiline Attributes (embedded in block inserts) ;;;; Tables ;;;; ;;;; Formats A string or a list of strings containing format "key code" ;;;; options. Each key code is mapped to a particular type of ;;;; format as listed below. A caret "^" preceding a format ;;;; code negates that format code, i.e. it explicitly means ;;;; not to remove that particular format. ;;;; ;;;; Available format key codes ;;;; -------------------------- ;;;; "A" = Alignment ;;;; "B" = taBs ;;;; "C" = Color ;;;; "D" = fielDs (converts fields to static text) ;;;; "F" = Font ;;;; "H" = Height ;;;; "L" = Linefeed (newline, line break, carriage return) ;;;; "M" = background Mask ;;;; "N" = columNs ;;;; "O" = Overline ;;;; "P" = Paragraph (embedded justification, line spacing, indents) ;;;; "Q" = obliQue ;;;; "S" = Stacking ;;;; "T" = Tracking ;;;; "U" = Underline ;;;; "W" = Width ;;;; "~" = non-breaking space ;;;; "*" = all formats ;;;; ;;;; ;;;; Example 1: ;;;; ;;;; Load the StripMText file from script or AutoLISP. Assumes ;;;; StripMtext file resides in an AutoCAD support file search folder: ;;;; ;;;; (load "StripMtext v5-0a") ;_ check and update file name ;;;; ;;;; ;;;; Example 2: ;;;; ;;;; Prompt the user to select objects and remove only color, font, & ;;;; height formatting. There will not be a dialog or any other prompt ;;;; for choosing formats. ;;;; ;;;; (if (setq ss (ssget)) (StripMtext ss "CFH")) ;;;; - OR - ;;;; (if (setq ss (ssget)) (StripMtext ss '("C" "F" "H"))) ;;;; ;;;; ;;;; Example 3: ;;;; ;;;; Remove all formatting except hard returns from all supported ;;;; entitites without a prompt: ;;;; ;;;; (StripMtext (ssget "x") "*^L") ;;;; - OR - ;;;; (StripMtext (ssget "x") '("*" "^L")) ;;;; ;;;; Caution: ;;;; ;;;; Never run the above function on a batch of drawings without a ;;;; thorough understanding of how the format removal options work and ;;;; how removing them affects the end results. Experiment to become ;;;; familiar with the options before using on a batch of drawings. ;;;; ;;;; ;;;; HISTORY ;;;; ;;;; v1.0 06-14-1999 "The DSAKO Years" R14 ;;;; A first attempt of dealing with the problem of removing Mtext ;;;; formatting came while writing a routine named "DSAKO" (short for ;;;; "Dimstyle Apply Keep Overrides"). It was discovered that Mtext ;;;; formatting was overriding the text style height and font. Wrote a ;;;; subfunction called ClearMtext which stripped font, height, and ;;;; stacked fraction formatting from Mtext. sd ;;;; ;;;; v2.0 08-25-2001 "First stand alone StripMtext version" ;;;; Faster speed and removes all current formatting possibilities, ;;;; except linefeeds. sd ;;;; ;;;; v3.0 05-26-2003 "The Uhden Unformat Version" Vlisp ;;;; Powered by the new Unformat parser function written by John Uhden, ;;;; which provided much better, faster, and more reliable format ;;;; removing than previous versions. Added support for dimensions ;;;; objects and introduced a new DCL allowing users to choose individual ;;;; formats and save defaults. sd ;;;; ;;;; v3.05 01-14-04 ;;;; "Quit/Exit" bug fixed. sd ;;;; ;;;; v3.06 03-21-04 ;;;; Only changes to comments, otherwise same as v3.05. sd ;;;; ;;;; v3.07 04-15-04 ;;;; Fixed a "Unknown dimension" bug when drawing contained 2LineAngular ;;;; dimensions. Thanks to Keith Kempker for reporting this error and for ;;;; helping with debugging. sd ;;;; ;;;; v3.08 03-22-06 ;;;; Per request from Paul Muti, exposed subfunctions such that ;;;; StripMtext may be run from a script or another lisp. sd ;;;; ;;;; v3.09 01-17-07 ;;;; Fixed "Error: bad argument value: positive 0" This bug was reported ;;;; by Joe Burke when the routine processes an mtext object which begins ;;;; with a return, example "\\Ptest". Joe also found the bug and ;;;; provided code to fix the problem! This version incorporates his ;;;; solution. Thanks Joe! sd ;;;; ;;;; v4.0 Beta - "The Lost Version" ;;;; This version was never released to the public due to programming ;;;; difficulties which I could not overcome. Since a few copies went ;;;; out for beta testing, I felt it necessary to include version 4 in ;;;; the history list so as to bump the next version up and avoid any ;;;; confusion with the so called lost version. sd ;;;; ;;;; ;;;; v5.0 01-01-10 "The Joe Burke RegExp Version" ;;;; The stripping functions in this version have been completely ;;;; rewritten by Joe Burke and make use of the search and replace power ;;;; of regular expressions via the RegExp object. Joe Burke's coding ;;;; added support to remove all current Mtext formatting codes including ;;;; new format codes for tabs, indents, embedded justification, fields, ;;;; columns, and background masks. Joe also added support for ;;;; processing new entity objects that contain mtext: Mleaders, Tables, ;;;; and Multiline Attributes. Other changes are the elimination of the ;;;; external DCL file by creating a temporary DCL written "on the fly". ;;;; Comments have been rewritten and expanded to make it easier for ;;;; new user to understand how to load and run. I also wish to thank ;;;; Lee Mac for creating animated GIFs demonstrating StripMtext in ;;;; action. sd ;;;; ;;;; v5.0a 02-01-10 ;;;; 1.) Changed handling of dimensions objects to preserve ;;;; associativity of measurement value. 2.) Fixed compatibility ;;;; issue when processing locked Table cells prior to AutoCAD 2008. ;;;; 3.) Fixed failure to remove columns when Textstyle is ;;;; annotative. 4.) Added work around for AutoCAD problem when ;;;; user issues an UNDO after stripping Fields. 5.) Improved ;;;; handling of stacked fractions to preserve readability. ;;;; Thanks to Ian Bryant for his IsAnnotative function. ;;;; ;;;; v5.0b 02-10-10 ;;;; Corrected wrong AutoCAD version number used to determine if ssget ;;;; filter should include Mleaders and Inserts objects. ;;;; ;;;; v5.0c 07-05-10 ;;;; Revised regular expression for Height format to include either upper or lower case x's ;;;; e.g. "\\H1.5x" or "\\H1.5X" ;;;; ;;;; GLOBALS LIST ;;;; ;;;; *REX* (blackboard) ;;;; *smt-acad* (blackboard) ;;;; *smt-doc* ;;;; *smt-blocks* ;;;; *smt-layers* ;;;; *smt-dclfilename* ;;;; *smt-smtver* ;;;; *sbar* ;;;; ;;;; C:SMT ;;;; C:StripMtext ;;;; StripMtext ;;;; StripMtextDCL ;;;; smt-acad ;;;; smt-doc ;;;; smt-blocks ;;;; smt-layers ;;;; (vl-load-com) (setq *smt-smtver* "5.0c") ;; How globals to objects are defined may change in future version (defun smt-acad () ;; Sets and returns global var referencing Acad ojbect ;; Stores var in blackboard namespace (cond ((vl-bb-ref '*smt-acad*)) (t (vl-bb-set '*smt-acad* (vlax-get-acad-object))) ) ) (defun smt-doc () ;; Sets and returns global var referencing doc object (cond (*smt-doc*) (t (setq *smt-doc* (vla-get-activedocument (smt-acad)))) ) ) (defun smt-blocks () ;; Sets and returns global var referencing the blocks collection (cond (*smt-blocks*) (t (setq *smt-blocks* (vla-get-blocks (smt-doc)))) ) ) (defun smt-layers () ;; Sets and returns global var referencing the layers collection (cond (*smt-layers*) (t (setq *smt-layers* (vla-get-layers (smt-doc)))) ) ) ;; (defun c:StripMtext (/ *error* ss formats count acadver ssfilter) ;; ;; User command ;; (defun *error* (msg) (vla-endundomark (smt-doc)) (cond ((vl-position msg '("Function cancelled" "quit / exit abort" "console break") ) ) ((princ (strcat "\nStripMtext Error: " msg))) ) ;; SD 12-20-09 vl-filename-mktemp not consistently deleting temp files (if *smt-dclfilename* (vl-file-delete *smt-dclfilename*) ) ;; Added JB 11/16/2009 Cmdecho is set to 0 in the StripMLeader function. (setvar "cmdecho" 1) (princ) ) ;; added version specific ssget filter SD 2-2-10 (setq acadver (atof (getvar "acadver"))) (setq ssfilter "MTEXT,DIMENSION") (if (>= acadver 16.1) ;_Acad2005 (setq ssfilter (strcat ssfilter ",ACAD_TABLE")) ) (if (>= acadver 17.1) ;_Acad2008 corrected ver num 2-10-10 (setq ssfilter (strcat ssfilter ",MULTILEADER,INSERT")) ) (setq ssfilter (list (cons 0 ssfilter))) ;; (vla-startundomark (smt-doc)) (setvar "cmdecho" 0) ;_ SD 2-0-10 (prompt (strcat "\nStripMtext v" *smt-smtver*)) (if (and (setq ss (ssget ;_ get selection ":L" ssfilter ) ) (setq formats (StripMtextDCL)) ;_ get options (setq count (StripMtext ss formats)) ;_ process ) (princ (strcat "\nStripMtext completed. " ;_ print report (itoa count) " objects processed." ) ) (princ "\t*Cancel*") ) (setvar "cmdecho" 1) (vla-endundomark (smt-doc)) (princ) ) (defun c:SMT () (c:StripMtext)) ;_shortcut ;;; (defun StripMtextDCL (/ acadver dcl_id formats keylist user regkey _AcceptButton _ClearAllButton _dclWrite _KeyToggle _RunDialog _SelectAllButton ) ;; ;; Function to create the DCL for StripMtext ;; Arguments: None ;; Returns: User input from DCL or nil ;; (defun _dclWrite (/ dclcode filename filehandle) ;; Makes a temporary DCL file at runtime ;; Returns name of the file or NIL (setq dclcode (list ;_ tilenames are case sensitive "// Temporary DCL file" (strcat "stripmtext" ":dialog {label = \"StripMtext v" *smt-smtver* "\";" ) (strcat ":text { value = \"Removes formatting from " "Mtext, Mleaders, Dimensions, Tables, & " "Multiline Attributes\";}" ) "spacer_1; " ":toggle {key = \"save\"; label = \"Remember Settings\";} " "spacer_1; " ":boxed_row {label = \"Select type of formatting to remove\";" " :column { " " :toggle {key = \"A\"; label = \"Alignment\";} " " :toggle {key = \"C\"; label = \"Color\";} " " :toggle {key = \"F\"; label = \"Font\";} " " :toggle {key = \"H\"; label = \"Height\";} " " :toggle {key = \"L\"; label = \"Linefeed\";} " " :toggle {key = \"~\"; label = \"Nonbreaking~Space\";} " " :toggle {key = \"Q\"; label = \"Oblique\";} " " } " " :column { " " :toggle {key = \"O\"; label = \"Overline\";} " " :toggle {key = \"P\"; label = \"Paragraph\";} " " :toggle {key = \"S\"; label = \"Stacking\";} " " :toggle {key = \"B\"; label = \"Tabs\";} " " :toggle {key = \"T\"; label = \"Tracking\";} " " :toggle {key = \"U\"; label = \"Underline\";} " " :toggle {key = \"W\"; label = \"Width\";} " " } " " :column { " " :toggle {key = \"M\"; label = \"Background Masks\";} " " :toggle {key = \"D\"; label = \"Fields\";} " " :toggle {key = \"N\"; label = \"Columns\";} " " :spacer {height = 6.0;} " " } " " :column { " " :button {key = \"selectall\"; label = \"Select All\";} " " :button {key = \"clearall\"; label = \"Clear All\";} " " :spacer {height = 6.0;} " " } " "} " "errtile; " "ok_cancel; " "} " ) ) ;; Revised temp file name 12-20-09 sd (if (and (setq filename (vl-filename-mktemp "SMT" nil ".tmp")) (setq filehandle (open filename "w")) ) (progn (foreach line dclcode (write-line line filehandle)) (close filehandle) ) ) filename ) (defun _SelectAllButton () ;; Turn "on" all format toggle keys ;; Requires global variable 'keylist (mapcar '(lambda (key) (set_tile key "1")) keylist) (set_tile "error" "") (mode_tile "accept" 0) ;_ enable (mode_tile "accept" 2) ;_ focus ) (defun _ClearAllButton () ;; Turn "off" all format toggle keys ;; Requires global variable 'keylist (mapcar '(lambda (key) (set_tile key "0")) keylist) (set_tile "error" "Select one or more formats to remove or press \"Cancel\" to exit" ) (mode_tile "accept" 1) ;_ disable ) (defun _AcceptButton (/ formats) ;; Get and save user settings and exit dialog ;; Requires global variables 'keylist and 'regkey ;; Returns list of user chosen format keys (setq formats (vl-remove-if '(lambda (key) (= (get_tile key) "0")) keylist ) ) (vl-registry-write regkey "Save" (get_tile "save")) (if (= (get_tile "save") "1") (vl-registry-write regkey "Settings" (apply 'strcat formats)) ) (done_dialog 1) formats ) (defun _KeyToggle () ;; Turn on/off error message and enable/disable "ok" button ;; Requires global variable 'keylist (if (vl-some '(lambda (key) (= (get_tile key) "1")) keylist) (progn (mode_tile "accept" 0) (set_tile "error" "")) (progn (mode_tile "accept" 1) (set_tile "error" "Select one or more formats to remove or press \"Cancel\" to exit" ) ) ) ) (defun _RunDialog (/ status formats) ;; Display DCL with toggle preset with user's saved settings ;; Creates default settings when routine is run on first time ;; Requires global variables 'keylist, 'regkey, 'acaver, 'dcl_id ;; Requires functions '_ClearAllButton, _SelectAllButton, _AcceptButton ;; Returns list of chosen toggle/format keys if user exits DCL using Okay button ;; Returns NIL if user exits using Cancel button (set_tile "save" (cond ((vl-registry-read regkey "Save")) ((vl-registry-write regkey "Save" "1")) ) ) (mapcar '(lambda (key) (set_tile key "1")) (mapcar 'chr (vl-string->list (cond ((vl-registry-read regkey "Settings")) ((vl-registry-write regkey "Settings" "CFH")) ;_ default ) ) ) ) (if (> 16.1 acadver) ;_ disable fields & mask toggle keys (progn (mode_tile "M" 1) (mode_tile "D" 1)) ) (if (> 17.1 acadver) ;_ disble mtext columns toggle key (mode_tile "N" 1) ) ;; Define button callbacks and run dialog (mapcar '(lambda (key) (action_tile key "(_KeyToggle)")) keylist ) (action_tile "clearall" "(_ClearAllButton)") (action_tile "selectall" "(_SelectAllButton)") (action_tile "accept" "(setq formats (_AcceptButton))") (action_tile "cancel" "(done_dialog 0)") (setq status (start_dialog)) (unload_dialog dcl_id) ;; Added 12-20-09 sd Despite what the manual says, vl-filename-mktemp ;; files were not always being automatically deleted (vl-file-delete *smt-dclfilename*) ;; If status = 1 , then Accept button hit (if (= status 1) formats ) ) ;_ RunDialog ;; ;; Begin main DCL routine ;; (setq regkey "HKEY_CURRENT_USER\\SOFTWARE\\StripMtext\\" acadver (atof (getvar "acadver")) keylist (append (if (<= 15.0 acadver) ;_ vlisp required 2000 '("A" "B" "C" "F" "H" "L" "O" "Q" "P" "S" "T" "U" "W" "~" ) ) (if (<= 16.1 acadver) ;_ fields, mask, tables 2005 '("M" "D") ) (if (<= 17.1 acadver) ;_ mtext columns added 2008 '("N") ) ) ) (cond ;; Exit routine if not running in Acad 2000 or above ((not keylist) (alert "StripMtext Error:\nRequires AutoCAD 2000 or higher") ) ;; Create DCL file ((null (setq *smt-dclfilename* (_dclwrite))) (alert "StripMtext Error:\nUnable to write DCL file") ) ;; Exit if cannot find DCL file ((< (setq dcl_id (load_dialog *smt-dclfilename*)) 0) (alert (strcat "StripMtext Error:\nCannot load DCL file:\n" *smt-dclfilename* ) ) ) ;; Exit if DCL fails to load ((not (new_dialog "stripmtext" dcl_id)) (alert "StripMtext Error:\nCannot display dialog") ) ;; Run DCL and return user's chosen formats ((_RunDialog)) ) ) ;;; (defun StripMtext (ss formats / mtextobjlst mldrobjlst dimobjlst tableobjlst layers mattobjlst obj objname str cnt spinflag lockedcellflag ;; functions Spinbar FormatsToList StripFormat StripColumn StripMask StripField StripTableFields StripTable StripMLeader StripMAttribute RowsColumns CellFieldOwner SymbolString GetFields IsAnnotative GetAnnoScales) ;;; ;;; StripMtext ;;; ;;; Parses supplied list of format keys and selection set to determine which ;;; Strip* function to operate on which entities. Iterates through selected ;;; objects and passes appropriate arguments to appropriate Strip* function ;;; ;;; Returns count of entities processed ;;; ;;; 'ss argument is a pickset containing valid entities ;;; 'formats argument is a list of format keys: '("A" "C" ... "F") ;;; or a string of format keys: "ACF" ;;; ;;; For more info on syntax and valid arugments, please refer to ;;; "HOW TO USE BY SCRIPT OR AUTOLISP" in header comments at top of file, ;;; or read through comments in subs below. ;;; ;;; Powered by Joe Burke's stripping functions: ;;; ;;; StripColumn ;;; StripField ;;; StripFormat ;;; StripMask ;;; StripMAttribute ;;; StripMLeader ;;; StripTable ;;; StripTableFields ;;; SymbolString ;;; CellFieldOwner ;;; FormatsToList ;;; GetFields ;;; RowsColumns ;;; IsAnnotative ;;; GetAnnoScales ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Define Stripping functions ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Argument: either a list of strings or a string. ;; Given a list, ensure formats are uppercase. ;; Given a formats string, convert it to a list of uppercase strings. ;; Examples: (FormatsToList "fOU") > ("F" "O" "U") ;; (FormatsToList "f^OU") > ("F" "^O" "U") (defun FormatsToList (arg / lst) (cond ((= (type arg) 'LIST) (mapcar 'strcase arg) ) ((= (type arg) 'STR) (while (not (eq "" (substr arg 1))) (if (eq "^" (substr arg 1 1)) (setq lst (cons (strcat "^" (substr arg 2 1)) lst) arg (substr arg 3) ) (setq lst (cons (substr arg 1 1) lst) arg (substr arg 2) ) ) ) (mapcar 'strcase (reverse lst)) ) ) ) ; end FormatsToList ;; Arguments: ;; str - an mtext string. ;; formats - a list of format code strings or a string. ;; Format code arguments are not case sensitive. ;; Examples: ;; Remove Font, Overline and Underline formatting. ;; (StripFormat (list "f" "O" "U")) ;; Or a quoted list: ;; (StripFormat '("f" "O" "U")) ;; Or a string: ;; (StripFormat "fOU") ;; Remove all formatting except Overline and Underline. ;; (StripFormat (list "*" "^O" "^U")) ;; Or a quoted list: ;; (StripFormat '("*" "^O" "^U")) ;; Or a string: ;; (StripFormat "*^O^U") ;; Available codes: ;; A (^A) - Alignment ;; B (^B) - taBs ;; C (^C) - Color ;; F (^F) - Font ;; H (^H) - Height ;; L (^L) - Linefeed (newline, line break, carriage return) ;; O (^O) - Overline ;; Q (^Q) - obliQuing ;; P (^P) - Paragraph (embedded justification, line spacing and indents) ;; S (^S) - Stacking ;; T (^T) - Tracking ;; U (^U) - Underline ;; W (^W) - Width ;; ~ (^~) - non-breaking space ;; * - all formats (defun StripFormat (str formats / text slashflag lbrace rbrace RE:Replace RE:Execute Alignment Tab Color Font Height Linefeed Overline Paragraph Oblique Stacking Tracking Underline Width Braces HardSpace) (setq formats (FormatsToList formats)) ;; Access the RegExp object from the blackboard. ;; Thanks to Steve for this idea. (or (vl-bb-ref '*REX*) (vl-bb-set '*REX* (vlax-create-object "VBScript.RegExp")) ) (defun RE:Replace (newstr pat string) (vlax-put (vl-bb-ref '*REX*) 'Pattern pat) (vlax-put (vl-bb-ref '*REX*) 'Global actrue) (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse) (vlax-invoke (vl-bb-ref '*REX*) 'Replace string newstr) ) ;end (defun RE:Execute (pat string / result match idx lst) (vlax-put (vl-bb-ref '*REX*) 'Pattern pat) (vlax-put (vl-bb-ref '*REX*) 'Global actrue) (vlax-put (vl-bb-ref '*REX*) 'IgnoreCase acfalse) (setq result (vlax-invoke (vl-bb-ref '*REX*) 'Execute string)) (vlax-for x result (setq match (vlax-get x 'Value) idx (vlax-get x 'FirstIndex) ;; position within string - zero based - first position is zero lst (cons (list match idx) lst) ) ) lst ) ;end ;; Replace linefeeds using this format "\n" with the AutoCAD ;; standard format "\P". The "\n" format occurs when text is ;; copied to ACAD from some other application. (setq str (RE:Replace "\\P" "\\n" str)) ;;;;; Start remove formatting sub-functions ;;;;; ;; A format (defun Alignment (str) (RE:Replace "" "\\\\A[012];" str)) ;; B format (tabs) (defun Tab (str / lst origstr tempstr) (setq lst (RE:Execute "\\\\P\\t|[0-9]+;\\t" str)) (foreach x lst (setq origstr (car x) tempstr (RE:Replace "" "\\t" origstr) str (vl-string-subst tempstr origstr str) ) ) (RE:Replace " " "\\t" str) ) ;; C format (defun Color (str) ;; True color and color book integers are preceded ;; by a lower case "c". Standard colors use upper case "C". (RE:Replace "" "\\\\[Cc][0-9]?[.]?[0-9]+;" str) ) ;; F format (defun Font (str) (RE:Replace "" "\\\\[Ff].*?;" str)) ;; H format (defun Height (str) ;; revised 6/6/2010 ;(RE:Replace "" "\\\\H[0-9]?[.]?[0-9]+x;" str) (RE:Replace "" "\\\\H[0-9]*?[.]?[0-9]*?(x|X)+;" str) ) ;; L format ;; Leading linefeeds are not converted to spaces. (defun Linefeed (str / teststr) ;; Remove formatting from test string other than linefeeds. ;; Seems there's no need to check for stacking ;; because a linefeed will always come before stack formatting. (setq teststr (Alignment str) teststr (Color teststr) teststr (Font teststr) teststr (Height teststr) teststr (Overline teststr) teststr (Paragraph teststr) teststr (Oblique teststr) teststr (Tracking teststr) teststr (Underline teststr) teststr (Width teststr) teststr (Braces teststr) ) ;; Remove leading linefeeds. (while (eq "\\P" (substr teststr 1 2)) (setq teststr (substr teststr 3) str (vl-string-subst "" "\\P" str) ) ) (RE:Replace " " " \\\\P|\\\\P |\\\\P" str) ) ;; O format (defun Overline (str) (RE:Replace "" "\\\\[Oo]" str)) ;; This option is effectively the same as the Remove Formatting > ;; Remove Paragraph Formatting option avaiable in the 2008 Mtext editor. (defun Paragraph (str) (RE:Replace "" "\\\\p.*?;" str)) ;; Q format - numeric value may be negative. (defun Oblique (str) ;; Any real number including negative values. (RE:Replace "" "\\\\Q[-]?[0-9]*?[.]?[0-9]+;" str) ) ;; S format (defun Stacking (str / lst tempstr pos origstr teststr testpos numcheck) (setq lst (RE:Execute "\\\\S(.*?)(\\;)" str)) (foreach x lst (setq tempstr (car x) pos (cadr x) origstr tempstr ) ;; Remove formatting from test string other than stacking. (setq teststr (Alignment str) teststr (Color teststr) teststr (Font teststr) teststr (Height teststr) teststr (Linefeed teststr) teststr (Overline teststr) teststr (Paragraph teststr) teststr (Oblique teststr) teststr (Tracking teststr) teststr (Underline teststr) teststr (Width teststr) teststr (Braces teststr) ) ;; Remove all "{" characters if present. Added JB 2/1/2010. (setq teststr (RE:Replace "" "[{]" teststr)) ;; Get the stacked position within test string. (setq testpos (cadar (RE:Execute "\\\\S(.*?)(\\;)" teststr))) ;; Avoid an error with substr if testpos is zero. ;; A space should not be added given a stacked ;; fraction string which is simply like this 1/2" anyway. (if (/= 0 testpos) (setq numcheck (substr teststr testpos 1)) ) ;; Check whether the character before a stacked string/fraction ;; is a number. Add a space if it is. (if (and numcheck (<= 48 (ascii numcheck) 57) ) (setq tempstr (RE:Replace " " "\\\\S" tempstr)) (setq tempstr (RE:Replace "" "\\\\S" tempstr)) ) (setq tempstr (RE:Replace "/" "[#]" tempstr) tempstr (RE:Replace "" "[;]" tempstr) tempstr (RE:Replace "" "\\\\A(.*?)[;]" tempstr) tempstr (RE:Replace "" "\\^" tempstr) str (vl-string-subst tempstr origstr str pos) ) ) str ) ;; T format (defun Tracking (str) (RE:Replace "" "\\\\T[0-9]?[.]?[0-9]+;" str)) ;; U format (defun Underline (str) (RE:Replace "" "\\\\[Ll]" str)) ;; W format (defun Width (str) (RE:Replace "" "\\\\W[0-9]?[.]?[0-9]+;" str)) ;; ~ format ;; In 2008 a hard space includes font formatting. ;; In 2004 it does not, simply this \\~. (defun HardSpace (str) (RE:Replace " " "{\\\\[Ff](.*?)\\\\~}|\\\\~" str)) ;; Remove curly braces. Called after other formatting is removed. (defun Braces (str / lst origstr tempstr len teststr) (setq lst (RE:Execute "{[^\\\\]+}" str)) (foreach x lst (setq origstr (car x) tempstr (RE:Replace "" "[{}]" origstr) str (vl-string-subst tempstr origstr str) ) ) ;; Added JB 12/20/2009 ;; Last ditch attempt at remove braces from start and end of string. (setq len (strlen str)) (if (and (= 123 (ascii (substr str 1 1))) (= 125 (ascii (substr str len 1))) (setq teststr (substr str 2)) (setq teststr (substr teststr 1 (1- (strlen teststr)))) (not (vl-string-search "{" teststr)) (not (vl-string-search "}" teststr)) ) (setq str teststr) ) str ) ;;;;; End remove formatting sub-functions ;;;;; ;;;;; Start primary function ;;;;; ;; Temporarily replace literal backslashes with a unique string. ;; Literal backslashes are restored at end of function. By Steve Doman. (setq slashflag (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) ">")) (setq text (RE:Replace slashflag "\\\\\\\\" str)) ;; Temporarily replace literal left curly brace. (setq lbrace (strcat "")) (setq text (RE:Replace lbrace "\\\\{" text)) ;; Temporarily replace literal right curly brace. (setq rbrace (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) "R>")) (setq text (RE:Replace rbrace "\\\\}" text)) (if (or (vl-position "A" formats) (and (vl-position "*" formats) (not (vl-position "^A" formats))) ) (setq text (Alignment text)) ) (if (or (vl-position "B" formats) (and (vl-position "*" formats) (not (vl-position "^B" formats))) ) (setq text (Tab text)) ) (if (or (vl-position "C" formats) (and (vl-position "*" formats) (not (vl-position "^C" formats))) ) (setq text (Color text)) ) (if (or (vl-position "F" formats) (and (vl-position "*" formats) (not (vl-position "^F" formats))) ) (setq text (Font text)) ) (if (or (vl-position "H" formats) (and (vl-position "*" formats) (not (vl-position "^H" formats))) ) (setq text (Height text)) ) (if (or (vl-position "L" formats) (and (vl-position "*" formats) (not (vl-position "^L" formats))) ) (setq text (Linefeed text)) ) (if (or (vl-position "O" formats) (and (vl-position "*" formats) (not (vl-position "^O" formats))) ) (setq text (Overline text)) ) (if (or (vl-position "P" formats) (and (vl-position "*" formats) (not (vl-position "^P" formats))) ) (setq text (Paragraph text)) ) (if (or (vl-position "Q" formats) (and (vl-position "*" formats) (not (vl-position "^Q" formats))) ) (setq text (Oblique text)) ) (if (or (vl-position "S" formats) (and (vl-position "*" formats) (not (vl-position "^S" formats))) ) (setq text (Stacking text)) ) (if (or (vl-position "T" formats) (and (vl-position "*" formats) (not (vl-position "^T" formats))) ) (setq text (Tracking text)) ) (if (or (vl-position "U" formats) (and (vl-position "*" formats) (not (vl-position "^U" formats))) ) (setq text (Underline text)) ) (if (or (vl-position "W" formats) (and (vl-position "*" formats) (not (vl-position "^W" formats))) ) (setq text (Width text)) ) (if (or (vl-position "~" formats) (and (vl-position "*" formats) (not (vl-position "^~" formats))) ) (setq text (HardSpace text)) ) (setq text (Braces (RE:Replace "\\\\" slashflag text)) text (RE:Replace "\\{" lbrace text) text (RE:Replace "\\}" rbrace text) ) text ) ; end StripFormat ;; Added JB 1/27/2010. Used in the StripColumn function below. ;; by Ian Bryant ;; Return T if ename is annotative, otherwise nil. (defun IsAnnotative (e) (and e (setq e (cdr (assoc 360 (entget e)))) (setq e (dictsearch e "AcDbContextDataManager")) (setq e (dictsearch (cdr (assoc -1 e)) "ACDB_ANNOTATIONSCALES")) (assoc 350 e) ) ) ;end IsAnnotative ;; Added JB 1/27/2010. Used in the StripColumn function below. ;; Argument: the ename of an annotative object. ;; Returns: a list of annotative scales or nil if the object is ;; not annotative. (defun GetAnnoScales (e / dict lst rewind res) (if (and e (setq dict (cdr (assoc 360 (entget e)))) (setq lst (dictsearch dict "AcDbContextDataManager")) (setq lst (dictsearch (cdr (assoc -1 lst)) "ACDB_ANNOTATIONSCALES")) (setq dict (cdr (assoc -1 lst))) ) (progn (setq rewind T) (while (setq lst (dictnext dict rewind)) (setq e (cdr (assoc 340 lst)) res (cons (cdr (assoc 300 (entget e))) res) rewind nil ) ) ) ) (reverse res) ) ; end GetAnnoScales ;; Mtext columns were added in AutoCAD 2008. ;; Remove column formatting from an mtext object. ;; Argument: mtext vla-object. ;; Note: Though the DXF 75 code referenced here does not appear in an ;; entget mtext ename call, it can be used to removed column formatting. ;; See DXF Reference for mtext objects in 2008 or later. (defun StripColumn (obj / ename sclst) (if (and (>= (atof (getvar "AcadVer")) 17.1) (eq "AcDbMText" (vlax-get obj 'ObjectName)) (setq ename (vlax-vla-object->ename obj)) ) (cond ;; Added JB 1/26/2010. ;; Allows columns to be removed from annotative objects. ((and (IsAnnotative ename) (setq sclst (GetAnnoScales ename)) ) (setvar "cmdecho" 0) (command "._chprop" ename "" "_Annotative" "_No" "") (entmod (append (entget ename) '((75 . 0)))) (command "._chprop" ename "" "_Annotative" "_Yes" "") (foreach x sclst (command "._objectscale" ename "" "_Add" x "") ) (setvar "cmdecho" 1) ) ;; For non-annotative objects. (T (entmod (append (entget ename) '((75 . 0)))) ) ) ) ) ; end StripColumn ;; Background mask for mtext objects was added in AutoCAD 2005. ;; Remove background mask from mtext and multileader objects. ;; Argument: an mtext or multileader ename or vla-object. ;; Added support for dimensions. (defun StripMask (obj / frame elst maskcode str mbw) (cond ((and (eq "AcDbMText" (vlax-get obj 'ObjectName)) (vlax-property-available-p obj 'BackgroundFill) ) (vlax-put obj 'BackgroundFill 0) ) ((and (wcmatch (vlax-get obj 'ObjectName) "*Dimension*") (vlax-property-available-p obj 'TextFill) ) (vlax-put obj 'TextFill 0) ) ((and (eq "AcDbMLeader" (vlax-get obj 'ObjectName)) (vlax-property-available-p obj 'TextFrameDisplay) (setq frame (vlax-get obj 'TextFrameDisplay)) (setq elst (entget (vlax-vla-object->ename obj))) (setq maskcode (assoc 292 elst)) (/= 0 (cdr maskcode)) (entmod (subst (cons 292 0) maskcode elst)) ) (vlax-put obj 'TextFrameDisplay frame) ) ;; Preserve fields. ((and (eq "AcDbAttribute" (vlax-get obj 'ObjectName)) ;; check for 90 mask code (assoc 90 (entget (vlax-vla-object->ename obj))) ) (if ;; If the attribute does not have an extension dictionary or ;; the dictionary can be deleted because it is empty. (or (= 0 (vlax-get obj 'HasExtensionDictionary)) (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke (list (vlax-invoke obj 'GetExtensionDictionary) 'Delete) ) ) ) ) (setq str (SymbolString obj)) (setq str (GetFields obj nil)) ) (setq mbw (vlax-get obj 'MTextBoundaryWidth)) (vlax-put obj 'MTextAttribute 0) (vlax-put obj 'MTextAttribute -1) (vlax-put obj 'TextString str) (vlax-put obj 'MTextBoundaryWidth mbw) ) ) ) ; end StripMask ;; Fields were added in AutoCAD 2005. ;; Remove the fields dictionary from supported object types if it exists. ;; Argument: mtext, multiline attribute, mleader or dimension vla-object. ;; Returns: the object TextString with symbols intact. (defun StripField (obj / typ str dict) (setq typ (vlax-get obj 'ObjectName)) (if (or (eq typ "AcDbMText") (eq typ "AcDbAttribute") ) (setq str (SymbolString obj)) ) ;; Added JB 1/29/2008 to fix a problem with fields in multiline ;; attributes which do not update correctly when undo is called ;; afer running StripMtext. (if (eq typ "AcDbAttribute") (command "._updatefield" (vlax-vla-object->ename obj) "") ) (and (= -1 (vlax-get obj 'HasExtensionDictionary)) (not (vl-catch-all-error-p (setq dict (vl-catch-all-apply 'vlax-invoke (list obj 'GetExtensionDictionary)) ) ) ) (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke (list dict 'Remove "ACAD_FIELD")) ) ) (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke (list dict 'Delete)) ) ) str (vl-catch-all-apply 'vlax-put (list obj 'TextString str)) ) ;; Added 11/14/2009. Return str to StripTableField function. str ) ; end StripField (defun StripTableFields (obj / rows columns rclst row col mtxtobj str) (setq rows (vlax-get obj 'Rows) columns (vlax-get obj 'Columns) rclst (RowsColumns rows columns) ) (vla-put-RegenerateTableSuppressed obj :vlax-true) (foreach x rclst (setq row (car x) col (cadr x)) (cond ;; Revised JB 1/4/2010. ;; Cell is not a text cell. ((/= 1 (vlax-invoke obj 'GetCellType row col))) ;; Revised JB 1/21/2010 ;; Cell is locked in 2008 or later. Apparently cells cannot ;; be locked in versions prior to 2008. ((and (vlax-method-applicable-p obj 'GetCellState) (/= 0 (vlax-invoke obj 'GetCellState row col)) ) (setq lockedcellflag T) ) ((and (setq mtxtobj (CellFieldOwner obj row col)) (setq str (StripField mtxtobj)) ) (vlax-invoke obj 'SetText row col str) ) ) ) (vla-put-RegenerateTableSuppressed obj :vlax-false) ) ; end StripTableFields (defun StripTable (obj formats / blocks blkname blkobj rclst row col str getstr mtxtobjlst temprclst) (setq blocks (smt-blocks)) (setq blkname (cdr (assoc 2 (entget (vlax-vla-object->ename obj))))) (setq blkobj (vla-item blocks blkname)) (vlax-for x blkobj (if (and (eq "AcDbMText" (vlax-get x 'ObjectName)) (not (eq "" (vlax-get x 'TextString))) ) (setq mtxtobjlst (cons x mtxtobjlst)) ) ) (setq rclst (RowsColumns (vlax-get obj 'Rows) (vlax-get obj 'Columns))) (foreach x rclst (setq row (car x) col (cadr x)) (if (and (vlax-method-applicable-p obj 'GetCellState) (/= 0 (vlax-invoke obj 'GetCellState row col)) ) (setq lockedcellflag T) ) (if (not (eq "" (vlax-invoke obj 'GetText row col))) (setq temprclst (cons x temprclst)) ) ) (vla-put-RegenerateTableSuppressed obj acTrue) ;; The equal test may be temporary. Not sure yet. ;; Revised JB 1/24/2010. (if (= (length mtxtobjlst) (length temprclst)) (foreach x mtxtobjlst (setq str (SymbolString x)) (setq row (caar temprclst) col (cadar temprclst)) (setq str (StripFormat str formats)) (vlax-put x 'TextString str) (setq str (vlax-invoke x 'FieldCode)) (vl-catch-all-apply 'vlax-invoke (list obj 'SetText row col str) ) ;; Step through the list. (setq temprclst (cdr temprclst)) ) ) (vla-put-RegenerateTableSuppressed obj acFalse) ) ; end StripTable (defun StripMLeader (obj formats) (if ;; If the mleader does not have an extension dictionary or ;; the dictionary can be deleted because it is empty. (or (= 0 (vlax-get obj 'HasExtensionDictionary)) (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke (list (vlax-invoke obj 'GetExtensionDictionary) 'Delete) ) ) ) ) (vlax-put obj 'TextString (StripFormat (SymbolString obj) formats)) (progn (vlax-put obj 'TextString (GetFields obj formats)) (setvar "cmdecho" 0) (vl-cmdf "._updatefield" (vlax-vla-object->ename obj) "") (setvar "cmdecho" 1) (vla-update obj) (vlax-put obj 'TextFrameDisplay (vlax-get obj 'TextFrameDisplay)) ) ) ) ; end StripMLeader ;; Arguments: multiline attribute vla-object and a list of formats to remove. (defun StripMAttribute (obj formats) (if ;; If the attribute does not have an extension dictionary or ;; the dictionary can be deleted because it is empty. (or (= 0 (vlax-get obj 'HasExtensionDictionary)) (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke (list (vlax-invoke obj 'GetExtensionDictionary) 'Delete) ) ) ) ) (vlax-put obj 'TextString (StripFormat (SymbolString obj) formats)) (progn (vlax-put obj 'TextString (GetFields obj formats)) (vla-update obj) ) ) ) ; end StripMAttribute ;; Arguments: number of rows and columns in a table. ;; Example: (rowscolumns 2 3) > ((0 0) (1 0) (0 1) (1 1) (0 2) (1 2)) ;; Revised 11/13/2009 to return the list first reading left to right and ;; then top to bottom like this ((0 0) (0 1) (0 2) (1 0) (1 1) (1 2)) (defun RowsColumns (r c / n clst rlst lst) (setq n 0) (while (< n r) (setq rlst (cons n rlst)) (setq n (1+ n)) ) (setq n 0) (while (< n c) (setq clst (cons n clst)) (setq n (1+ n)) ) (foreach r rlst (foreach c clst (setq lst (cons (list r c) lst)) ) ) ) ; end RowsColumns ;; Thanks to James Allen for pointing out the GetFieldID method. ;; Arguments: table vla-object, row and column. ;; Returns: the mtext object if the cell contains a field, otherwise nil. (defun CellFieldOwner (tblobj row col / doc id owner) (setq doc (smt-doc)) (and (setq id (vlax-invoke tblobj 'GetFieldID row col)) (/= 0 id) (setq owner (vlax-invoke doc 'ObjectIDtoObject id)) (repeat 3 (setq owner (vlax-invoke doc 'ObjectIDtoObject (vlax-get owner 'OwnerID)) ) ) ) owner ) ; end CellFieldOwner ;; Argument: ename or vla-object. ;; Object types: mtext, attribute, mleader or dimension. ;; Returns: a string with symbols intact. (defun SymbolString (obj / e typ str name String blocks) ;; A multiline attributue may contain two 1 DXF codes and multiple ;; 3 DXF codes. In either case the first code 1 should be ingored ;; since it contains a string which is not displayed on screen. ;; Apparently this odd condition occurs when text is pasted on top ;; of existing text. The old text is stored in the first DXF code 1 ;; and the text displayed on screen is stored in the second DXF code 1. (defun String (ename / str lst) (setq str "") (setq lst (vl-remove-if-not '(lambda (x) (or (= 3 (car x)) (= 1 (car x)))) (entget ename) ) ) (if (and (< 1 (length lst)) (= 1 (caar lst))) (setq lst (cdr lst)) ) (foreach x lst (setq str (strcat str (cdr x))) ) ) ; end String (if (= (type obj) 'VLA-OBJECT) (setq e (vlax-vla-object->ename obj)) (progn (setq e obj) (setq obj (vlax-ename->vla-object obj)) ) ) (setq typ (vlax-get obj 'ObjectName)) (cond ((or (eq typ "AcDbMText") (eq typ "AcDbAttribute") ) (setq str (String e)) ) ((eq typ "AcDbMLeader") (setq str (cdr (assoc 304 (entget e)))) ) ;; Revised SD 1/15/2010. Looks good JB 1/19/2010. ((wcmatch typ "*Dimension*") (setq str (cdr (assoc 1 (entget e)))) ) ) str ) ; end SymbolString ;; Argument: multiline attribute or mleader vla-object. ;; Called by StripMAttribute and StripMLeader sub-functions. ;; Also called by StripMask to preserve fields in a multiline attribute. ;; Those functions check the the object has a dictionary or not. ;; This is a revised version of a St:GetFields from SwapText.lsp. ;; Returns: the same string as the FieldCode method with formatting ;; removed. Returns the source text string with formatting removed ;; if no fields are found in an attribute or mleader. ;; Note, FieldCode does not work with attributes or mleaders. ;; Create a new temporary mtext object. Apply source field dictionaries ;; to it. Then get the FieldCode from temp object and erase it. (defun GetFields (obj formats / srcdict srcdictename srcTEXTdict srcfieldename targdict targdictename fieldelst fielddict dicts actlay tempobj lockflag res doc) (setq doc (smt-doc)) (if (and (= -1 (vlax-get obj 'HasExtensionDictionary)) (setq srcdict (vlax-invoke obj 'GetExtensionDictionary)) (setq srcdictename (vlax-vla-object->ename srcdict)) (setq srcTEXTdict (dictsearch srcdictename "ACAD_FIELD")) (setq srcfieldename (cdr (assoc 360 srcTEXTdict))) ) (progn ;; Check for active layer locked. (setq actlay (vlax-get doc 'ActiveLayer)) (if (= -1 (vlax-get actlay 'Lock)) (progn (vlax-put actlay 'Lock 0) (setq lockflag T) ) ) (setq tempobj (vlax-invoke (vlax-get (vla-get-ActiveLayout doc) 'Block) 'AddMText '(0.0 0.0 0.0) 0.0 "x" ) ) (setq targdict (vlax-invoke tempobj 'GetExtensionDictionary) targdictename (vlax-vla-object->ename targdict) fieldelst (entget srcfieldename) ;; not sure about the need for these fieldelst (vl-remove (assoc 5 fieldelst) fieldelst) fieldelst (vl-remove (assoc -1 fieldelst) fieldelst) fieldelst (vl-remove (assoc 102 fieldelst) fieldelst) fieldelst (vl-remove-if '(lambda (x) (= 330 (car x))) fieldelst) ) (foreach x fieldelst (if (= 360 (car x)) (progn (setq dicts (cons (cdr x) dicts)) ) ) ) ;; remove all 360s from fieldelst (setq fieldelst (vl-remove-if '(lambda (x) (= 360 (car x))) fieldelst)) (foreach x (reverse dicts) (setq fieldelst (append fieldelst (list (cons 360 (entmakex (entget x))))) ) ) (setq fielddict (dictadd targdictename "ACAD_FIELD" (entmakex '( (0 . "DICTIONARY") (100 . "AcDbDictionary") (280 . 1) (281 . 1) ) ) ) ) (dictadd fielddict "TEXT" (entmakex fieldelst) ) ;; Revised 11/23/2009. (vlax-put tempobj 'TextString (StripFormat (SymbolString tempobj) formats) ) (setq res (vlax-invoke tempobj 'FieldCode)) (vla-delete tempobj) (if lockflag (vlax-put actlay 'Lock -1)) ) ; progn ;; Else return the text string with formatting removed. ;; Unlikely this would be used. (setq res (StripFormat (SymbolString obj) formats)) ) ; if res ) ; end GetFields ;; Author unknown. (defun Spinbar (sbar) (cond ((= sbar "\\") "|") ((= sbar "|") "/") ((= sbar "/") "-") (t "\\") ) ) ;_end spinbar ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Begin Main StripMtext function ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (vl-load-com) (setq formats (FormatsToList formats)) (setq layers (smt-layers)) ;; Sort the selection set to lists by object type. (setq cnt 0) (repeat (sslength ss) (setq obj (vlax-ename->vla-object (ssname ss cnt)) objname (vlax-get-property obj "ObjectName") cnt (1+ cnt) ) (cond ((eq objname "AcDbMText") ;_ Mtext AutoCAD R13+ (setq mtextobjlst (cons obj mtextobjlst)) ) ((and (eq objname "AcDbMLeader") ;_ Mleader AutoCAD 2008+ (vlax-property-available-p obj 'ContentType) (= 2 (vlax-get obj 'ContentType)) ) (setq mldrobjlst (cons obj mldrobjlst)) ) ((and (eq objname "AcDbBlockReference") ;_ Multiline Atts AutoCAD 2008+ (vlax-property-available-p obj 'HasAttributes) (= -1 (vlax-get obj 'HasAttributes)) (vlax-method-applicable-p obj 'GetAttributes) ) (foreach x (vlax-invoke obj 'GetAttributes) (if (and (vlax-property-available-p x 'MTextAttribute) (= -1 (vlax-get x 'MTextAttribute)) (= 0 (vlax-get (vla-item layers (vlax-get x 'Layer)) 'Lock) ) ) (setq mattobjlst (cons x mattobjlst)) ) ) ) ((vl-position objname '("AcDbAlignedDimension" "AcDbRotatedDimension" "AcDbOrdinateDimension" "AcDsbAngularDimension" "AcsDb2LineAngularDimension" "AcDb3PointAngularDimension" "AscDbDiametricDimension" "AcDbRadialDimension" "AcDbRadialDimensionLarge" "AcDbArcDimension" ) ) (setq dimobjlst (cons obj dimobjlst)) ) ((eq objname "AcDbTable") ;_ AutoCAD 2005+ (setq tableobjlst (cons obj tableobjlst)) ) ) ) ;; ;; Parse format list and invoke Strip* functions w/ appropriate arguments ;; (if (or (vl-position "*" formats) (vl-position "D" formats)) (progn (foreach x mtextobjlst (StripField x)) (foreach x mldrobjlst (StripField x)) (foreach x dimobjlst (StripField x)) (foreach x mattobjlst (StripField x)) (foreach x tableobjlst (StripTableFields x)) ) ) (if (or (vl-position "*" formats) (vl-position "N" formats)) (foreach x mtextobjlst (StripColumn x)) ) (if (or (vl-position "*" formats) (vl-position "M" formats)) (progn (foreach x mtextobjlst (StripMask x)) (foreach x mldrobjlst (StripMask x)) (foreach x dimobjlst (StripMask x)) (foreach x mattobjlst (StripMask x)) ) ) (if (setq formats (vl-remove-if '(lambda (key) (vl-position key '("M" "D" "N" "^M" "^D" "^N")) ) formats ) ) (progn (setq spinflag (> (length mtextobjlst) 100)) (foreach x mtextobjlst (setq str (StripFormat (SymbolString x) formats)) (vlax-put x 'TextString str) (if spinflag (princ (strcat "\rProcessing... " (setq *sbar* (Spinbar *sbar*)) "\t" ) ) ) ) (setq spinflag (> (length mldrobjlst) 100)) (foreach x mldrobjlst (StripMLeader x formats) (if spinflag (princ (strcat "\rProcessing... " (setq *sbar* (Spinbar *sbar*)) "\t" ) ) ) ) (setq spinflag (> (length dimobjlst) 100)) (foreach x dimobjlst (setq str (StripFormat (SymbolString x) formats)) (vlax-put-property x 'TextOverride str) ;; Added JB 1/19/2010. Updates the dimension object ;; which is needed in some cases. (entget (vlax-vla-object->ename x)) (if spinflag (princ (strcat "\rProcessing... " (setq *sbar* (Spinbar *sbar*)) "\t" ) ) ) ) (setq spinflag (> (length mattobjlst) 100)) (foreach x mattobjlst (StripMAttribute x formats) (if spinflag (princ (strcat "\rProcessing... " (setq *sbar* (Spinbar *sbar*)) "\t" ) ) ) ) (setq spinflag (> (length tableobjlst) 25)) (foreach x tableobjlst (StripTable x formats) (if spinflag (princ (strcat "\rProcessing... " (setq *sbar* (Spinbar *sbar*)) "\t" ) ) ) ) ) ) (if lockedcellflag ;_ this var is created in StripTable (princ "\nSome table cells are locked. ") ) ;; calculate count (+ (length mtextobjlst) (length mldrobjlst) (length dimobjlst) (length mattobjlst) (length tableobjlst) ) ) ;;; End StripMtext ;; (princ (strcat "\nStripMtext v" *smt-smtver* " by Steve Doman and Joe Burke") ) (princ "\nStart routine by typing \"STRIPMTEXT\" or \"SMT\" for short.") (princ)