- UID
- 151438
- 积分
- 440
- 精华
- 贡献
-
- 威望
-
- 活跃度
-
- D豆
-
- 在线时间
- 小时
- 注册时间
- 2004-6-21
- 最后登录
- 1970-1-1
|
发表于 2004-10-13 20:31:16
|
显示全部楼层
Steve Doman有这样一个VLisp程序,你可以参考一下:
STRIPMTEXT[3].LSP
[php];|
StripMtext v3.07 for AutoCAD 2000 thru 2004
This program creates a user command that will quickly remove
formatting applied to individual characters and words inside
Mtext objects.
StripMtext can remove the following types of formatting:
Alignment
Color
Font
Height
Underscore
Overscore
Linefeed (Paragraph Return)
Obliquing
Stacking
Tracking
Width
Non-breaking Space
StripMtext does not modify Mtext properties such as style,
justification, width, and rotation. Nor does it manipulate
inherited properties such as layer, entity color, etc.
Note:
Removing Mtext formatting is a very complex procedure. This program
has been designed to safely remove formatting but no guarantee
exist. Until you become familiar with StripMtext, please save your
drawing before using. If you do not like the results, you can
immediatly issue an Undo command to restore your Mtext to its prior
condition. You are encouraged to spend a few minutes experimenting
with different format removal settings on sample drawings before
using this program on your real drawings.
How to use:
(1) When you start StripMtext, you will be asked to select Mtext and
Dimension objects.
(2) After you have completed selecting, a dialog box will appear
that contains several check boxes labeled with formatting names.
Check mark each type of formatting you want removed.
(3) If you would like StripMtext to use your current check marked
formats as your default, check mark the "Remember Settings" box.
(4) Hit OK to process, or Cancel to abort.
History:
v1.0 11-17-1999
Removes font formatting from Mtext objects
v2.0 08-25-2001
Faster speed and removes all formatting from Mtext (except linefeed)
v3.0 05-26-2003
Improved format removal by replacing prior format strip functions
with John Uhden's more robust 'UnFormat function.
Added Support for dimension Mtext.
Added dialog so user can choose which formatting to remove.
Added feature to save default format options
v3.05 01-14-04
"Quit/Exit" Bug fixed
v3.06 03-21-04
Only changes to comments, otherwise same as v3.05
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.
Credits:
John Uhden for donating his brillant and robust 'UnFormat function
which perfoms the actually format parsing.
Joe Burke, the Number 1 user and beta tester!
User interface written by Steve Doman
This program is donated to the public domain.
Anyone experiencing any bugs or annoyances from this program is
encourage to report them so that it can continue to be improved.
Without feedback, nothing happens.
Please send comments, wish list, or bug reports to: sdoman@qwest.net
|;
(defun c:StripMtext ( /
; Functions
*error*
AcceptButton
ClearAllButton
MainDialog
SelectAllButton
Setup
StripMtext
Unformat
; Variables
dcl_id
dclfilemsg
dclfilename
dialogmsg
keylist
modcnt
save
settings
space
ss
tilemsg
versionmsg
)
;;; Local functions
(defun *error* (msg)
(if docobj (vla-endundomark docobj))
(cond
((member msg
'("Function cancelled"
"quit / exit abort"
"console break"
)
)
)
((princ (strcat " Error: " msg)))
)
(princ)
)
(defun SelectAllButton ()
(foreach key keylist (set_tile key on))
(set_tile "error" "")
(mode_tile "accept" 2)
)
(defun ClearAllButton ()
(foreach key keylist (set_tile key off))
(set_tile "error" tilemsg)
)
(defun AcceptButton ()
;Build string to be passed later to the unformat function
;Strcat key character for each checkmarked key
(setq settings "")
(foreach key keylist
(if (= (get_tile key) on)
(setq settings (strcat settings key))
)
)
;If no keys are checkmarked, show error message
;Else if save is enabled, save settings to registry
(if (= settings "")
(set_tile "error" tilemsg)
(progn
(if (= (get_tile "save") on)
(progn
(vl-registry-write StripMtextKey "Settings" settings)
(vl-registry-write StripMtextKey "Save" on)
)
(vl-registry-write StripMtextKey "Save" off)
)
(if (= (strlen settings) (length keylist))
(setq settings "*")
)
);progn
)
)
(defun MainDialog ( / status done)
;Display checkbox default values and define checkbox callbacks
(set_tile "save" save)
(foreach key keylist
(if (vl-string-search key settings)(set_tile key on))
(action_tile key "(set_tile \"error\" \"\" )" )
)
;Define button callbacks
(action_tile "clearall" "(ClearAllButton)")
(action_tile "selectall" "(SelectAllButton)")
(action_tile "accept" "(AcceptButton)(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(setq status (start_dialog))
(unload_dialog dcl_id)
;Return key used to close dialog
;If status = 0 , then Cancel button hit
;If status = 1 , then Accept button hit
status
)
; The following function was written by John Uhden
; This version of Unformat is slightly modified from the original.
;
; Thanks John!
;
; -------------------------------------------------
;
; Primary function to perform the format stripping:
; Arguments:
; Mtext - the text string to be Unformatted
; Formats - a string containing some or all of
; the following characters:
;
; A - Alignment
; C - Color
; F - Font
; H - Height
; L - Underscore
; O - Overscore
; P - Linefeed (Paragraph)
; Q - Obliquing
; S - Spacing (Stacking)
; T - Tracking
; W - Width
; ~ - Non-breaking Space
; Optional Formats -
; * - All formats
; Returns:
; nil - if not a valid Mtext object
; Text - the Mtext textstring with none, some, or all
; of the formatting removed, depending on what
; formats were present and what formats were
; specified for removal.
;
(defun UnFormat (Mtext Formats / All Format1 Format2 Text Str)
(and
Mtext
Formats
(= (type Mtext) 'STR)
(= (type Formats) 'STR)
(setq Formats (strcase Formats))
(setq Text "")
(setq All T)
(if (= Formats "*")
(setq Formats "S"
Format1 "\\[LO`~]"
Format2 "\\[ACFHQTW]"
Format3 "\\P"
)
(progn
(setq Format1 "" Format2 "" Format3 "")
(foreach item '("L" "O" "~")
(if (vl-string-search item Formats)
(setq Format1 (strcat Format1 "`" item))
(setq All nil)
)
)
(if (= Format1 "")
(setq Format1 nil)
(setq Format1 (strcat "\\[" Format1 "]"))
)
(foreach item '("A" "C" "F" "H" "Q" "T" "W")
(if (vl-string-search item Formats)
(setq Format2 (strcat Format2 item))
(setq All nil)
)
)
(if (= Format2 "")
(setq Format2 nil)
(setq Format2 (strcat "\\[" Format2 "]"))
)
(if (vl-string-search "P" Formats)
(setq Format3 "\\P")
(setq Format3 nil All nil)
)
T
)
)
(while (/= Mtext "")
(cond
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
(setq Mtext (substr Mtext 3)
Text (strcat Text Str)
)
)
((and All (wcmatch (substr Mtext 1 1) "[{}]"))
(setq Mtext (substr Mtext 2))
)
((and Format1 (wcmatch (strcase (substr Mtext 1 2)) Format1))
(setq Mtext (substr Mtext 3))
)
((and Format2 (wcmatch (strcase (substr Mtext 1 2)) Format2))
(setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext))))
)
((and Format3 (wcmatch (strcase (substr Mtext 1 2)) Format3))
(if
(or
(= " " (substr Text (strlen Text)))
(= " " (substr Mtext 3 1))
)
(setq Mtext (substr Mtext 3))
(setq Mtext (substr Mtext 3) Text (strcat Text " "))
)
)
((and (vl-string-search "S" Formats)(wcmatch (strcase (substr Mtext 1 2)) "\\S"))
(setq Str (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
Text (strcat Text (vl-string-translate "#^\\" "/^\\" Str))
Mtext (substr Mtext (+ 4 (strlen Str)))
)
)
(1
(setq Text (strcat Text (substr Mtext 1 1))
Mtext (substr Mtext 2)
)
)
)
)
)
Text
)
(defun StripMtext (ss / docobj cnt mtextobj objname txtprop txtvalue errobj)
;The argument 'ss must be a pickset containing at least
;one Mtext or Dimension entity
;Repeat for each entity in pickset:
; Get Mtext textstring and pass it to the Unformat function
; Put returned stripped textstring back into entity
; If successful, increment count of modified entities
(vl-load-com)
(setq
docobj (vlax-get-property (vlax-get-acad-object) "ActiveDocument")
cnt 0
modcnt 0
)
(vla-startundomark docobj)
(repeat (sslength ss)
(setq
mtextobj (vlax-ename->vla-object (ssname ss cnt))
objname (vlax-get-property mtextobj "ObjectName")
txtprop (cond
((= objname "AcDbMText")
"Textstring"
)
((member objname
'("AcDb3PointAngularDimension"
"AcDbAlignedDimension"
"AcDbAngularDimension"
"AcDb2LineAngularDimension"
"AcDbDiametricDimension"
"AcDbOrdinateDimension"
"AcDbRadialDimension"
"AcDbRotatedDimension"
)
)
"Textoverride"
)
(t
(alert
(strcat "StripMtext Error:"
"\nSorry, unknown dimension type"
"\n"
"\nPlease report error to:"
"\nsdoman@qwest.net"
)
)
)
)
txtvalue (vlax-get-property mtextobj txtprop)
errobj (vl-catch-all-apply
'vlax-put-property
(list
mtextobj
txtprop
(Unformat txtvalue settings)
)
)
modcnt (if (not (vl-catch-all-error-p errobj))(1+ modcnt))
cnt (1+ cnt)
);setq
);repeat
(vla-endundomark docobj)
)
(defun Setup ()
(setq
;--- Set Constants ---
;Toggles for dcl checkbox status
on "1"
off "0"
;Error messages
tilemsg "Select one or more settings or press \"Cancel\" to exit"
versionmsg "StripMtext error:\nRequires AutoCAD 2000 or higher"
dialogmsg "StripMtext error:\nUnable to load dialog"
dclfilemsg "StripMtext error:\nCannot load DCL file \"StripMtext[3].dcl\""
;DCL file
dclfilename "StripMtext[3].dcl"
;List of dcl checkbox key names
;Must correspond with DCL keys and Unformat function
keylist '("A" "C" "F" "H" "L" "O" "P" "Q" "S" "T" "W" "~")
;Registry path for storing user's settings
StripMtextkey "HKEY_CURRENT_USER\\SOFTWARE\\StripMtext\\"
;--- Set Defaults ---
;Get user's default settings from registry if exist
;If user has not saved default settings, use coded default
settings (cond
((vl-registry-read StripMtextKey "Settings"))
((vl-registry-write StripMtextKey "Settings" "CFH"))
)
save (cond
((vl-registry-read StripMtextKey "Save"))
((vl-registry-write StripMtextKey "Save" "1"))
)
);setq
)
;;;
;;; Main Program
;;;
(princ "\nStripMtext v3.07")
(Setup)
(cond
;Running in Acad 2000 or above
((< (atoi (getvar "acadver")) 15)
(alert versionmsg)
)
;Find dcl file
((< (setq dcl_id (load_dialog dclfilename)) 0)
(alert dclfilemsg)
)
;Succesful pickset
((not (setq ss (ssget ":L" '((0 . "MTEXT,DIMENSION") ))))
(princ "\nNothing selected")
)
;Successful dcl load
((not (new_dialog "stripmtext" dcl_id))
(alert dialogmsg)
)
;If user exits dcl using Accept button, process pickset
((= (MainDialog) 1)
;Process
(StripMtext ss)
;Display count of stripped objects
(princ
(strcat
"\nStripped: " (itoa modcnt) " mtext object"
(if (= 1 modcnt) " " "s ")
)
)
)
);cond
(princ)
);program
(princ "\nStripMtext v3.07 loaded. Start command by typing \"STRIPMTEXT\" ")
(princ)
[/php]
STRIPMTEXT[3].DCL
[php]
/// StripMtext[3].DCL Steve Doman sdoman@yahoo.com
stripmtext : dialog {
label = "StripMtext v3.06";
spacer_1;
: toggle {
label = "Remember Settings";
key = "save";
fixed_width = true;
}
spacer_1;
: boxed_row {
label = "Select type of formats to remove";
: column {
: toggle {
label = "Alignment";
key = "A";
fixed_width = true;
}
: toggle {
label = "Color";
key = "C";
fixed_width = true;
}
: toggle {
label = "Font";
key = "F";
fixed_width = true;
}
: toggle {
label = "Height";
key = "H";
fixed_width = true;
}
: toggle {
label = "Underline";
key = "L";
fixed_width = true;
}
: toggle {
label = "Overscrore";
key = "O";
fixed_width = true;
}
}
: column {
: toggle {
label = "Linefeed";
key = "P";
fixed_width = true;
}
: toggle {
label = "Oblique";
key = "Q";
fixed_width = true;
}
: toggle {
label = "Stacking";
key = "S";
fixed_width = true;
}
: toggle {
label = "Tracking";
key = "T";
fixed_width = true;
}
: toggle {
label = "Width";
key = "W";
fixed_width = true;
}
: toggle {
label = "Non-breaking Space";
key = "~";
fixed_width = true;
width = 1;
}
}
: column {
: button {
key = "selectall";
label = "Select All";
}
: button {
key = "clearall";
label = "Clear All";
}
: spacer {
height = 4.0;
}
}
}
: column {
errtile;
ok_cancel;
}
}
[/php] |
|