lecrabe Posté(e) le 7 août 2020 Posté(e) le 7 août 2020 Hello Je redonne ici une Super Routine qui "attaque" les MTEXTs : STRIPMTEXT en version 5.0D Au fait SVP si vous avez une meilleure version, je suis preneur !? Elle permet "d'attaquer" les formatages specifiques des MTEXTs ... Sur AutoCAD 2021, SVP regardez bien la remarque du Grand Maitre Gilles concernant LISPSYS = 0 LA SANTE (Stay Safe), Bye, lecrabe "triste"Automne 2020, la retraite ;; ;; ******** Please : BE Careful with this Lisp Routine ******** ;; ;; http://ww3.cad.de/foren/ubb/uploads/cadffm/StripMtextv5-0d.lsp ;; ;; ;; https://cadxp.com/topic/48901-lisp-stripmtext-et-autocad-2021/page__pid__292970 ;; ;; ---- Par GC : Probl avec AutoCAD 2021 potentiel !? ---- ;; Je crois bien que StripMText utilise VBScript.Regexp qui ne supporte pas les caractères Unicode, ;; or le support de ces caractères est une des nouveauté LISP apportées par cette version (CF ce sujet). ;; Essaye de mettre la variable système LISPSYS à 0 (un redémarrage d'AutoCAD est peut-être nécessaire) ;; pour redéfinir l'ancien IDE (VLIDE) et son environnement qui ne supportait pas Unicode. ;; ;;;; ;;;; StripMtext Version 5.0d 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 ;;;; ;;;; AutoCAD 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" ;;;; ;;;; v5.0d ??cadffm?? ;;;; Revised regular expression for Height format - ;;;; e.g. for format like this: H0.400000 ;;;; ;;;; ;;;; 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.0d") ;; How globals to objects are defined may change in future version (defun smt-acad () ;; Sets and returns global var referencing AutoCAD ojbect ;; Stores var in blackboard namespace (cond ((vl-bb-ref '*smt-acad*)) (t (vl-bb-set '*smt-acad* (vlax-get-acad-object))) ) ;_ end of cond ) ;_ end of defun (defun smt-doc () ;; Sets and returns global var referencing doc object (cond (*smt-doc*) (t (setq *smt-doc* (vla-get-activedocument (smt-acad)))) ) ;_ end of cond ) ;_ end of defun (defun smt-blocks () ;; Sets and returns global var referencing the blocks collection (cond (*smt-blocks*) (t (setq *smt-blocks* (vla-get-blocks (smt-doc)))) ) ;_ end of cond ) ;_ end of defun (defun smt-layers () ;; Sets and returns global var referencing the layers collection (cond (*smt-layers*) (t (setq *smt-layers* (vla-get-layers (smt-doc)))) ) ;_ end of cond ) ;_ end of defun ;; (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") ) ;_ end of vl-position ) ((princ (strcat "\nStripMtext Error: " msg))) ) ;_ end of cond ;; SD 12-20-09 vl-filename-mktemp not consistently deleting temp files (if *smt-dclfilename* (vl-file-delete *smt-dclfilename*) ) ;_ end of if ;; Added JB 11/16/2009 Cmdecho is set to 0 in the StripMLeader function. (setvar "cmdecho" 1) (princ) ) ;_ end of defun ;; 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")) ) ;_ end of if (if (>= acadver 17.1) ;_Acad2008 corrected ver num 2-10-10 (setq ssfilter (strcat ssfilter ",MULTILEADER,INSERT")) ) ;_ end of if (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 ) ;_ end of ssget ) ;_ end of setq (setq formats (StripMtextDCL)) ;_ get options (setq count (StripMtext ss formats)) ;_ process ) ;_ end of and (princ (strcat "\nStripMtext completed. " ;_ print report (itoa count) " objects processed." ) ;_ end of strcat ) ;_ end of princ (princ "\t*Cancel*") ) ;_ end of if (setvar "cmdecho" 1) (vla-endundomark (smt-doc)) (princ) ) ;_ end of defun (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* "\";" ) ;_ end of strcat (strcat ":text { value = \"Removes formatting from " "Mtext, Mleaders, Dimensions, Tables, & " "Multiline Attributes\";}" ) ;_ end of strcat "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; " "} " ) ;_ end of list ) ;_ end of setq ;; Revised temp file name 12-20-09 sd (if (and (setq filename (vl-filename-mktemp "SMT" nil ".tmp")) (setq filehandle (open filename "w")) ) ;_ end of and (progn (foreach line dclcode (write-line line filehandle)) (close filehandle) ) ;_ end of progn ) ;_ end of if filename ) ;_ end of defun (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 ) ;_ end of defun (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" ) ;_ end of set_tile (mode_tile "accept" 1) ;_ disable ) ;_ end of defun (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 ) ;_ end of vl-remove-if ) ;_ end of setq (vl-registry-write regkey "Save" (get_tile "save")) (if (= (get_tile "save") "1") (vl-registry-write regkey "Settings" (apply 'strcat formats) ) ;_ end of vl-registry-write ) ;_ end of if (done_dialog 1) formats ) ;_ end of defun (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" ) ;_ end of set_tile ) ;_ end of progn ) ;_ end of if ) ;_ end of defun (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")) ) ;_ end of cond ) ;_ end of set_tile (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 ) ;_ end of cond ) ;_ end of vl-string->list ) ;_ end of mapcar ) ;_ end of mapcar (if (> 16.1 acadver) ;_ disable fields & mask toggle keys (progn (mode_tile "M" 1) (mode_tile "D" 1)) ) ;_ end of if (if (> 17.1 acadver) ;_ disble mtext columns toggle key (mode_tile "N" 1) ) ;_ end of if ;; Define button callbacks and run dialog (mapcar '(lambda (key) (action_tile key "(_KeyToggle)")) keylist ) ;_ end of mapcar (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 ) ;_ end of if ) ;_ 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" "~" ) ) ;_ end of if (if (<= 16.1 acadver) ;_ fields, mask, tables 2005 '("M" "D") ) ;_ end of if (if (<= 17.1 acadver) ;_ mtext columns added 2008 '("N") ) ;_ end of if ) ;_ end of append ) ;_ end of setq (cond ;; Exit routine if not running in AutoCAD 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* ) ;_ end of strcat ) ;_ end of alert ) ;; 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)) ) ;_ end of cond ) ;_ end of defun ;;; (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) ) ;_ end of setq (setq lst (cons (substr arg 1 1) lst) arg (substr arg 2) ) ;_ end of setq ) ;_ end of if ) ;_ end of while (mapcar 'strcase (reverse lst)) ) ) ;_ end of cond ) ; 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")) ) ;_ end of or (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) ) ;_ end of setq ) ;_ end of vlax-for lst ) ;end ;; Replace linefeeds using this format "\n" with the AutoCAD ;; standard format "\P". The "\n" format occurs when text is ;; copied to AutoCAD 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) ) ;_ end of setq ) ;_ end of foreach (RE:Replace " " "\\t" str) ) ;_ end of defun ;; 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) ) ;_ end of defun ;; 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) ;old ;(RE:Replace "" "\\\\H[0-9]*?[.]?[0-9]*?(x|X)+;" str) ;new ;; revised cadffm ??? (RE:Replace "" "\\\\H[0-9]*?[.]?[0-9]*?(x|X|)+;" str) ) ;_ end of defun ;; 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) ) ;_ end of setq ;; Remove leading linefeeds. (while (eq "\\P" (substr teststr 1 2)) (setq teststr (substr teststr 3) str (vl-string-subst "" "\\P" str) ) ;_ end of setq ) ;_ end of while (RE:Replace " " " \\\\P|\\\\P |\\\\P" str) ) ;_ end of defun ;; 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) ) ;_ end of defun ;; 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 ) ;_ end of setq ;; 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) ) ;_ end of setq ;; 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)) ) ;_ end of if ;; 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) ) ;_ end of and (setq tempstr (RE:Replace " " "\\\\S" tempstr)) (setq tempstr (RE:Replace "" "\\\\S" tempstr)) ) ;_ end of if (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) ) ;_ end of setq ) ;_ end of foreach str ) ;_ end of defun ;; T format (defun Tracking (str) (RE:Replace "" "\\\\T[0-9]?[.]?[0-9]+;" str) ) ;_ end of defun ;; U format (defun Underline (str) (RE:Replace "" "\\\\[Ll]" str)) ;; W format (defun Width (str) (RE:Replace "" "\\\\W[0-9]?[.]?[0-9]+;" str) ) ;_ end of defun ;; ~ format ;; In 2008 a hard space includes font formatting. ;; In 2004 it does not, simply this \\~. (defun HardSpace (str) (RE:Replace " " "{\\\\[Ff](.*?)\\\\~}|\\\\~" str) ) ;_ end of defun ;; 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) ) ;_ end of setq ) ;_ end of foreach ;; 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)) ) ;_ end of and (setq str teststr) ) ;_ end of if str ) ;_ end of defun ;;;;; 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) ">") ) ;_ end of setq (setq text (RE:Replace slashflag "\\\\\\\\" str)) ;; Temporarily replace literal left curly brace. (setq lbrace (strcat "<L" (substr (rtos (getvar "CDATE") 2 8) 14) ">") ) ;_ end of setq (setq text (RE:Replace lbrace "\\\\{" text)) ;; Temporarily replace literal right curly brace. (setq rbrace (strcat "<" (substr (rtos (getvar "CDATE") 2 8) 14) "R>") ) ;_ end of setq (setq text (RE:Replace rbrace "\\\\}" text)) (if (or (vl-position "A" formats) (and (vl-position "*" formats) (not (vl-position "^A" formats)) ) ;_ end of and ) ;_ end of or (setq text (Alignment text)) ) ;_ end of if (if (or (vl-position "B" formats) (and (vl-position "*" formats) (not (vl-position "^B" formats)) ) ;_ end of and ) ;_ end of or (setq text (Tab text)) ) ;_ end of if (if (or (vl-position "C" formats) (and (vl-position "*" formats) (not (vl-position "^C" formats)) ) ;_ end of and ) ;_ end of or (setq text (Color text)) ) ;_ end of if (if (or (vl-position "F" formats) (and (vl-position "*" formats) (not (vl-position "^F" formats)) ) ;_ end of and ) ;_ end of or (setq text (Font text)) ) ;_ end of if (if (or (vl-position "H" formats) (and (vl-position "*" formats) (not (vl-position "^H" formats)) ) ;_ end of and ) ;_ end of or (setq text (Height text)) ) ;_ end of if (if (or (vl-position "L" formats) (and (vl-position "*" formats) (not (vl-position "^L" formats)) ) ;_ end of and ) ;_ end of or (setq text (Linefeed text)) ) ;_ end of if (if (or (vl-position "O" formats) (and (vl-position "*" formats) (not (vl-position "^O" formats)) ) ;_ end of and ) ;_ end of or (setq text (Overline text)) ) ;_ end of if (if (or (vl-position "P" formats) (and (vl-position "*" formats) (not (vl-position "^P" formats)) ) ;_ end of and ) ;_ end of or (setq text (Paragraph text)) ) ;_ end of if (if (or (vl-position "Q" formats) (and (vl-position "*" formats) (not (vl-position "^Q" formats)) ) ;_ end of and ) ;_ end of or (setq text (Oblique text)) ) ;_ end of if (if (or (vl-position "S" formats) (and (vl-position "*" formats) (not (vl-position "^S" formats)) ) ;_ end of and ) ;_ end of or (setq text (Stacking text)) ) ;_ end of if (if (or (vl-position "T" formats) (and (vl-position "*" formats) (not (vl-position "^T" formats)) ) ;_ end of and ) ;_ end of or (setq text (Tracking text)) ) ;_ end of if (if (or (vl-position "U" formats) (and (vl-position "*" formats) (not (vl-position "^U" formats)) ) ;_ end of and ) ;_ end of or (setq text (Underline text)) ) ;_ end of if (if (or (vl-position "W" formats) (and (vl-position "*" formats) (not (vl-position "^W" formats)) ) ;_ end of and ) ;_ end of or (setq text (Width text)) ) ;_ end of if (if (or (vl-position "~" formats) (and (vl-position "*" formats) (not (vl-position "^~" formats)) ) ;_ end of and ) ;_ end of or (setq text (HardSpace text)) ) ;_ end of if (setq text (Braces (RE:Replace "\\\\" slashflag text)) text (RE:Replace "\\{" lbrace text) text (RE:Replace "\\}" rbrace text) ) ;_ end of setq 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 of and ) ;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") ) ;_ end of setq (setq dict (cdr (assoc -1 lst))) ) ;_ end of and (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 ) ;_ end of setq ) ;_ end of while ) ;_ end of progn ) ;_ end of if (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)) ) ;_ end of and (cond ;; Added JB 1/26/2010. ;; Allows columns to be removed from annotative objects. ((and (IsAnnotative ename) (setq sclst (GetAnnoScales ename)) ) ;_ end of and (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 "") ) ;_ end of foreach (setvar "cmdecho" 1) ) ;; For non-annotative objects. (T (entmod (append (entget ename) '((75 . 0)))) ) ) ;_ end of cond ) ;_ end of if ) ; 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) ) ;_ end of and (vlax-put obj 'BackgroundFill 0) ) ((and (wcmatch (vlax-get obj 'ObjectName) "*Dimension*") (vlax-property-available-p obj 'TextFill) ) ;_ end of and (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)) ) ;_ end of and (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))) ) ;_ end of and (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 ) ;_ end of list ) ;_ end of vl-catch-all-apply ) ;_ end of vl-catch-all-error-p ) ;_ end of not ) ;_ end of or (setq str (SymbolString obj)) (setq str (GetFields obj nil)) ) ;_ end of if (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 of cond ) ; 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") ) ;_ end of or (setq str (SymbolString obj)) ) ;_ end of if ;; 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) "") ) ;_ end of if (and (= -1 (vlax-get obj 'HasExtensionDictionary)) (not (vl-catch-all-error-p (setq dict (vl-catch-all-apply 'vlax-invoke (list obj 'GetExtensionDictionary) ) ;_ end of vl-catch-all-apply ) ;_ end of setq ) ;_ end of vl-catch-all-error-p ) ;_ end of not (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke (list dict 'Remove "ACAD_FIELD") ) ;_ end of vl-catch-all-apply ) ;_ end of vl-catch-all-error-p ) ;_ end of not (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke (list dict 'Delete)) ) ;_ end of vl-catch-all-error-p ) ;_ end of not str (vl-catch-all-apply 'vlax-put (list obj 'TextString str)) ) ;_ end of and ;; 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) ) ;_ end of setq (vla-put-RegenerateTableSuppressed obj :vlax-true) (foreach x rclst (setq row (car x) col (cadr x) ) ;_ end of setq (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)) ) ;_ end of and (setq lockedcellflag T) ) ((and (setq mtxtobj (CellFieldOwner obj row col)) (setq str (StripField mtxtobj)) ) ;_ end of and (vlax-invoke obj 'SetText row col str) ) ) ;_ end of cond ) ;_ end of foreach (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))) ) ;_ end of and (setq mtxtobjlst (cons x mtxtobjlst)) ) ;_ end of if ) ;_ end of vlax-for (setq rclst (RowsColumns (vlax-get obj 'Rows) (vlax-get obj 'Columns)) ) ;_ end of setq (foreach x rclst (setq row (car x) col (cadr x) ) ;_ end of setq (if (and (vlax-method-applicable-p obj 'GetCellState) (/= 0 (vlax-invoke obj 'GetCellState row col)) ) ;_ end of and (setq lockedcellflag T) ) ;_ end of if (if (not (eq "" (vlax-invoke obj 'GetText row col))) (setq temprclst (cons x temprclst)) ) ;_ end of if ) ;_ end of foreach (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) ) ;_ end of setq (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) ) ;_ end of vl-catch-all-apply ;; Step through the list. (setq temprclst (cdr temprclst)) ) ;_ end of foreach ) ;_ end of if (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) ) ;_ end of vl-catch-all-apply ) ;_ end of vl-catch-all-error-p ) ;_ end of not ) ;_ end of or (vlax-put obj 'TextString (StripFormat (SymbolString obj) formats) ) ;_ end of vlax-put (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 of vlax-put ) ;_ end of progn ) ;_ end of if ) ; 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) ) ;_ end of vl-catch-all-apply ) ;_ end of vl-catch-all-error-p ) ;_ end of not ) ;_ end of or (vlax-put obj 'TextString (StripFormat (SymbolString obj) formats) ) ;_ end of vlax-put (progn (vlax-put obj 'TextString (GetFields obj formats)) (vla-update obj) ) ;_ end of progn ) ;_ end of if ) ; 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)) ) ;_ end of while (setq n 0) (while (< n c) (setq clst (cons n clst)) (setq n (1+ n)) ) ;_ end of while (foreach r rlst (foreach c clst (setq lst (cons (list r c) lst)) ) ;_ end of foreach ) ;_ end of foreach ) ; 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) ) ;_ end of vlax-invoke ) ;_ end of setq ) ;_ end of repeat ) ;_ end of and 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) ) ;_ end of vl-remove-if-not ) ;_ end of setq (if (and (< 1 (length lst)) (= 1 (caar lst))) (setq lst (cdr lst)) ) ;_ end of if (foreach x lst (setq str (strcat str (cdr x))) ) ;_ end of foreach ) ; 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)) ) ;_ end of progn ) ;_ end of if (setq typ (vlax-get obj 'ObjectName)) (cond ((or (eq typ "AcDbMText") (eq typ "AcDbAttribute") ) ;_ end of or (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)))) ) ) ;_ end of cond 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))) ) ;_ end of and (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) ) ;_ end of progn ) ;_ end of if (setq tempobj (vlax-invoke (vlax-get (vla-get-ActiveLayout doc) 'Block) 'AddMText '(0.0 0.0 0.0) 0.0 "x" ) ;_ end of vlax-invoke ) ;_ end of setq (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 ) ;_ end of vl-remove-if ) ;_ end of setq (foreach x fieldelst (if (= 360 (car x)) (progn (setq dicts (cons (cdr x) dicts)) ) ;_ end of progn ) ;_ end of if ) ;_ end of foreach ;; remove all 360s from fieldelst (setq fieldelst (vl-remove-if '(lambda (x) (= 360 (car x))) fieldelst ) ;_ end of vl-remove-if ) ;_ end of setq (foreach x (reverse dicts) (setq fieldelst (append fieldelst (list (cons 360 (entmakex (entget x))))) ) ;_ end of setq ) ;_ end of foreach (setq fielddict (dictadd targdictename "ACAD_FIELD" (entmakex '( (0 . "DICTIONARY") (100 . "AcDbDictionary") (280 . 1) (281 . 1) ) ) ;_ end of entmakex ) ;_ end of dictadd ) ;_ end of setq (dictadd fielddict "TEXT" (entmakex fieldelst) ) ;_ end of dictadd ;; Revised 11/23/2009. (vlax-put tempobj 'TextString (StripFormat (SymbolString tempobj) formats) ) ;_ end of vlax-put (setq res (vlax-invoke tempobj 'FieldCode)) (vla-delete tempobj) (if lockflag (vlax-put actlay 'Lock -1) ) ;_ end of if ) ; 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 of cond ) ;_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) ) ;_ end of setq (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)) ) ;_ end of and (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) ) ;_ end of and (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) ) ;_ end of = ) ;_ end of and (setq mattobjlst (cons x mattobjlst)) ) ;_ end of if ) ;_ end of foreach ) ((vl-position objname '("AcDbAlignedDimension" "AcDbRotatedDimension" "AcDbOrdinateDimension" "AcDsbAngularDimension" "AcsDb2LineAngularDimension" "AcDb3PointAngularDimension" "AscDbDiametricDimension" "AcDbRadialDimension" "AcDbRadialDimensionLarge" "AcDbArcDimension" ) ) ;_ end of vl-position (setq dimobjlst (cons obj dimobjlst)) ) ((eq objname "AcDbTable") ;_ AutoCAD 2005+ (setq tableobjlst (cons obj tableobjlst)) ) ) ;_ end of cond ) ;_ end of repeat ;; ;; 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)) ) ;_ end of progn ) ;_ end of if (if (or (vl-position "*" formats) (vl-position "N" formats)) (foreach x mtextobjlst (StripColumn x)) ) ;_ end of if (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)) ) ;_ end of progn ) ;_ end of if (if (setq formats (vl-remove-if '(lambda (key) (vl-position key '("M" "D" "N" "^M" "^D" "^N")) ) ;_ end of lambda formats ) ;_ end of vl-remove-if ) ;_ end of setq (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" ) ;_ end of strcat ) ;_ end of princ ) ;_ end of if ) ;_ end of foreach (setq spinflag (> (length mldrobjlst) 100)) (foreach x mldrobjlst (StripMLeader x formats) (if spinflag (princ (strcat "\rProcessing... " (setq *sbar* (Spinbar *sbar*)) "\t" ) ;_ end of strcat ) ;_ end of princ ) ;_ end of if ) ;_ end of foreach (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" ) ;_ end of strcat ) ;_ end of princ ) ;_ end of if ) ;_ end of foreach (setq spinflag (> (length mattobjlst) 100)) (foreach x mattobjlst (StripMAttribute x formats) (if spinflag (princ (strcat "\rProcessing... " (setq *sbar* (Spinbar *sbar*)) "\t" ) ;_ end of strcat ) ;_ end of princ ) ;_ end of if ) ;_ end of foreach (setq spinflag (> (length tableobjlst) 25)) (foreach x tableobjlst (StripTable x formats) (if spinflag (princ (strcat "\rProcessing... " (setq *sbar* (Spinbar *sbar*)) "\t" ) ;_ end of strcat ) ;_ end of princ ) ;_ end of if ) ;_ end of foreach ) ;_ end of progn ) ;_ end of if (if lockedcellflag ;_ this var is created in StripTable (princ "\nSome table cells are locked. ") ) ;_ end of if ;; calculate count (+ (length mtextobjlst) (length mldrobjlst) (length dimobjlst) (length mattobjlst) (length tableobjlst) ) ;_ end of + ) ;_ end of defun ;;; End StripMtext ;; (princ (strcat "\nStripMtext v" *smt-smtver* " by Steve Doman and Joe Burke" ) ;_ end of strcat ) ;_ end of princ (princ "\nStart routine by typing \"STRIPMTEXT\" or \"SMT\" for short." ) ;_ end of princ (princ) ;|«Visual LISP© Format Options» (72 2 40 1 T "end of " 60 9 0 0 0 nil T nil T) ;*** KEINEN Text unterhalb des Kommentars hinzufügen! ***|; Autodesk Expert Elite Team
Messages recommandés
Créer un compte ou se connecter pour commenter
Vous devez être membre afin de pouvoir déposer un commentaire
Créer un compte
Créez un compte sur notre communauté. C’est facile !
Créer un nouveau compteSe connecter
Vous avez déjà un compte ? Connectez-vous ici.
Connectez-vous maintenant