Strike Through Text, Mtext, Le

Bill_Myron · 发表于 2022-7-5 18:30:05

Due to some of our drafting guidelines, we need to strike through Text, Mtext, Leaders, Multileaders, Dimensions. The only issue is the strike through needs to be on a different layer.Therefore we cant use the default in the text editor for our needs.

Did some looking around today for and stumbled upon Lee Mac's Strike Through program. This program is close to what we would like to use, but it only for single line text.

Wondering if it is possible to add to the program to allow it to Strike Through Mtext, Leaders, Multileaders, Dimensions. Another cool option would be to have the polyline associate with the object. If you moved the object, it would move with it.

If that is not possible or too much work, simply setting the polyline creation to the current layer would help immensely.

A link to Lee Mac's program:
http://www.lee-mac.com/strikethrough.html

copy

;; Single Strikethrough(defun c:strike ( / i s )   (if (setq s (ssget '((0 . "TEXT,MTEXT"))))       (repeat (setq i (sslength s))           (LM:strikethrough (ssname s (setq i (1- i)))              '(                   (0.0 0.1)               )           )       )   )   (princ));; Double Strikethrough(defun c:strike2 ( / i s )   (if (setq s (ssget '((0 . "TEXT,MTEXT"))))       (repeat (setq i (sslength s))           (LM:strikethrough (ssname s (setq i (1- i)))              '(                   ( 0.15 0.1)                   (-0.15 0.1)               )           )       )   )   (princ));; Triple Strikethrough(defun c:strike3 ( / i s )   (if (setq s (ssget '((0 . "TEXT,MTEXT"))))       (repeat (setq i (sslength s))           (LM:strikethrough (ssname s (setq i (1- i)))              '(                   ( 0.2 0.1)                   ( 0.0 0.1)                   (-0.2 0.1)               )           )       )   )   (princ));; Underline(defun c:under ( / i s )   (if (setq s (ssget '((0 . "TEXT,MTEXT"))))       (repeat (setq i (sslength s))           (LM:strikethrough (ssname s (setq i (1- i)))              '(                   (-0.8 0.1)               )           )       )   )   (princ));; Double Underline(defun c:under2 ( / i s )   (if (setq s (ssget '((0 . "TEXT,MTEXT"))))       (repeat (setq i (sslength s))           (LM:strikethrough (ssname s (setq i (1- i)))              '(                   (-0.8  0.05)                   (-1.0  0.05)               )           )       )   )   (princ));; Double Overline & Underline(defun c:overunder2 ( / i s )   (if (setq s (ssget '((0 . "TEXT,MTEXT"))))       (repeat (setq i (sslength s))           (LM:strikethrough (ssname s (setq i (1- i)))              '(                   ( 1.0 0.05)                   ( 0.8 0.05)                   (-0.8 0.05)                   (-1.0 0.05)               )           )       )   )   (princ));; Strikethrough Text  -  Lee Mac;; Generates polylines through the supplied text object, with spacing & width given by the supplied parameter list.;; ent - [ent] Text or MText entity;; par - [lst] List of (( ) ... ) for each polyline;; Returns: [lst] List of created polyline entities(defun LM:strikethrough ( ent par / ang enx hgt lst md1 md2 rtn )   (if (setq lst (mytextbox (setq enx (entget ent))))       (progn           (setq hgt (cdr (assoc 40 enx))                 md1 (mid   (car  lst) (last  lst))                 md2 (mid   (cadr lst) (caddr lst))                 ang (angle (car  lst) (last  lst))           )           (foreach itm par               (setq rtn                   (cons                       (entmakex                           (append                              '(   (000 . "LWPOLYLINE")                                   (100 . "AcDbEntity")                                   (100 . "AcDbPolyline")                                   (090 . 2)                                   (070 . 0)                               )                               (LM:defaultprops enx)                               (list                                   (cons  043 (* (cadr itm) hgt))                                   (cons  038 (caddar lst))                                   (cons  010 (polar md1 ang (* (car itm) hgt)))                                   (cons  010 (polar md2 ang (* (car itm) hgt)))                                   (assoc 210 enx)                               )                           )                       )                       rtn                   )               )           )       )   )   rtn);; Midpoint  -  Lee Mac;; Returns the midpoint of two points(defun mid ( a b )   (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) a b));; Default Properties  -  Lee Mac;; Returns a list of DXF properties for the supplied DXF data,;; substituting default values for absent DXF groups(defun LM:defaultprops ( enx )   (mapcar '(lambda ( x ) (cond ((assoc (car x) enx)) ( x )))      '(           (006 . "BYLAYER")           (008 . "0")           (039 . 0.0)           (048 . 1.0)           (062 . 256)           (370 . -1)       )   ));; Text Box  -  gile / Lee Mac;; Returns an OCS point list describing a rectangular frame surrounding the supplied Text or MText entity;; enx - [lst] Text or MText DXF data list(defun mytextbox ( enx / bpt hgt jus lst ocs org rot wid )   (cond       (   (= "TEXT" (cdr (assoc 00 enx)))           (setq bpt (cdr (assoc 10 enx))                 rot (cdr (assoc 50 enx))                 lst (textbox enx)                 lst (list (car lst) (list (caadr lst) (cadar lst)) (cadr lst) (list (caar lst) (cadadr lst)))           )       )       (   (= "MTEXT" (cdr (assoc 00 enx)))           (setq ocs  (cdr (assoc 210 enx))                 bpt  (trans (cdr (assoc 10 enx)) 0 ocs)                 rot  (angle '(0.0 0.0) (trans (cdr (assoc 11 enx)) 0 ocs))                 wid  (cdr (assoc 42 enx))                 hgt  (cdr (assoc 43 enx))                 jus  (cdr (assoc 71 enx))                 org  (list (cond ((member jus '(2 5 ) (/ wid -2.0)) ((member jus '(3 6 9)) (- wid))      (0.0))                            (cond ((member jus '(1 2 3)) (- hgt))      ((member jus '(4 5 6)) (/ hgt -2.0)) (0.0))                      )                 lst  (list org (mapcar '+ org (list wid 0)) (mapcar '+ org (list wid hgt)) (mapcar '+ org (list 0 hgt)))           )       )   )   (if lst       (   (lambda ( m ) (mapcar '(lambda ( p ) (mapcar '+ (mxv m p) bpt)) lst))           (list               (list (cos rot) (sin (- rot)) 0.0)               (list (sin rot) (cos rot)     0.0)              '(0.0 0.0 1.0)           )       )   ));; Matrix x Vector  -  Vladimir Nesterovsky;; Args: m - nxn matrix, v - vector in R^n(defun mxv ( m v )   (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m))(princ)

StevJ · 发表于 2022-7-5 18:36:16

Bill,

I've been using Lee's excellent strikethrough program for a while and, although the projects I work on require single line text because our processing software can't assign attributes to multiline text, being able to designate a specific layer for the strike lines has benefits, and so I use the method below.
Apologies to Lee Mac for dirtying up his code - I'm sure there's a much better way to do this.

I added a line to a part his program which put the strikethroughs on the layer indicated. Side benefit is that if the layer name given is not present, it will be created (thanks, Lee). Ran as shown as a test and the LAYERNAME layer was created, with all strike lines on that layer. I have no idea if position in the list is critical - the first time I tried it was on the second line of the list and it worked, so I left it. See the addition in red below. Change LAYERNAME to the layer you wish the strike lines.

Steve

copy

(LM:defaultprops enx)         (list             (cons  043 (* (cadr itm) hgt))             [b][color=red](cons  008 "LAYERNAME")[/color][/b]             (cons  038 (caddar lst))             (cons  010 (polar md1 ang (* (car itm) hgt)))             (cons  010 (polar md2 ang (* (car itm) hgt)))             (assoc 210 enx)         )

Lee Mac · 发表于 2022-7-5 18:45:36

No need to apologise Steve - I'm delighted to hear that you find the program so useful, and thank you for assisting in my absence.

Generally, the position of the DXF groups corresponding to basic object properties (such as layer / colour / linetype / lineweight etc.) within the DXF data list does not matter.

However, in this particular case, you are lucky to have inserted the new DXF group in the position that you have, as this exploits a subtle behaviour of how the DXF data is interpreted.

The expression (LM:defaultprops enx) is retrieving the DXF groups corresponding to the basic object properties from the selected text object (such that the strikethrough polyline has matching properties), and so there is already a layer group present in the DXF data list; however, in most versions of AutoCAD, the DXF data is interpreted such that if there are multiple occurrences of DXF groups for which only one is required, only the last occurrence is used.

An alternative solution would be to modify the code in the following way:

copy

(append  '(   (000 . "LWPOLYLINE")       (100 . "AcDbEntity")       (100 . "AcDbPolyline")       [highlight](008 . "YourLayerHere")[/highlight]       (090 . 2)       (070 . 0)   )  [highlight];[/highlight](LM:defaultprops enx)   (list       (cons  043 (* (cadr itm) hgt))       (cons  038 (caddar lst))       (cons  010 (polar md1 ang (* (car itm) hgt)))       (cons  010 (polar md2 ang (* (car itm) hgt)))       (assoc 210 enx)   ))

StevJ · 发表于 2022-7-5 18:52:44

Modified the code as recommended, and thanks for the explanation.

Steve

Lee Mac · 发表于 2022-7-5 18:54:24

You're most welcome Steve.

Bill_Myron · 发表于 2022-7-5 19:00:17

Thats what I ended up doing as well.

Adjusting the 008 code layer to my needs.

Thanks again!

lordnk · 发表于 2022-7-5 19:10:03

Oh my god, this program is amazing, I've been doing this manually for a long time and to think of all the time we could have saved!

The only edit which I am having trouble with is that my MTEXTs are generally multiline, and each line is a difference width.

I made a crude edit to the source which calculated the height of the mtext block itself, found the text height and then divided it to make lines appear in the right locations, but I run into problems, such as that each line is a different length, but the line that the program draws is the full width of the text block - I have no idea how I would calculate the width of each line. Even then I'm not sure that I see anywhere in the XY arguments to give a line width, although I guess it couldn't be too hard to 'brute force' something together.

I had a thought, maybe copy each line of the MTEXT to a TEXT, run the strike command on each new TEXT, then remove the TEXT, leaving the MTEXT underneath the lines that were drawn for the TEXTs? Brute force for sure.

So before I go hacking apart what is an amazingly elegant piece of work, has anyone run across this problem before or have any suggestions on how I might do this a bit smarter? Appreciate any help/direction that can be given.

Oh and I just realized this is my first post ever on this forum! So hi guys! Thanks for all the great advice/examples/scripts/etc that I've been lurking around in for ages now

lordnk · 发表于 2022-7-5 19:14:14

Well I got sidetracked and didn't get any time to look at this, now I'm back on the case. My idea is to:

Run a command
Click on a line of text within MTEXT block
Convert that line to green inside the MTEXT
Make a copy of that line in the exact same position over the top of the MTEXT
Use the STRIKE command on the extra line
Remove the extra line
--

Which SHOULD then allow the user to click on a line of text and have it changed colour & striked out with a polyline, but the MTEXT object remains in the same place & only a new polyline is done over the exact length of the selected line.

First step.. have the user select an MTEXT and make a copy of it, exactly the same spot then EXPLODE the MTEXT in order to make a bunch of TEXTs overlaying the original MTEXT object.

Second step.. Take the clicked point and run another select to select the TEXT object (single line of the mtext) that was clicked on, remove the other non-matching TEXTs.

Third step, run the STRIKE command on the TEXT object
Fourth step, remove the TEXT object

Fifth step, change the line inside the MTEXT to the correct color, somehow? How would this be done, some kind of regular expression perhaps? I would have the value of the TEXT object, which I could use to do a find/replace and just put the colour code around the matching text inside the MTEXT object? Is there a particular function to do this?

Thanks again for any help that anyone can give me

lordnk · 发表于 2022-7-5 19:20:23

Okay, well, here's something that half works.

copy

(defun st ( / ) (setq es (entsel "\nSelect MTEXT:")       en (car es)       cp (cadr es)       vo (vlax-ename->vla-object en)       vc (vla-copy (vlax-ename->vla-object en))       vcc (vla-put-visible vc :vlax-false)       ex (vl-cmdf "explode" en)       ss (ssget "_P")       s (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))       ot (ssname (ssget cp '((0 . "TEXT"))) 0)       os (vla-get-textstring (vlax-ename->vla-object ot))       textCol "8"   ) (if ss       (progn        (vlax-for o s          (progn (setq tstr (vla-get-textstring o))                 (if (= tstr os)                              (progn                                (vl-cmdf "draworder" (vlax-vla-object->ename o) "" "_front")                         (LM:strikethrough (vlax-vla-object->ename o) '((0.0 0.1)))                         (vl-cmdf "erase" (vlax-vla-object->ename o) "")                              )                       (vl-cmdf "erase" (vlax-vla-object->ename o) "")                 )          )        )             (vla-delete s)       )          ) (setq text (vl-string-subst (strcat "\\C" textCol ";" os "\\C256;") os (vla-get-textstring vc))) (vla-put-textstring vc text) (vla-put-visible vc :vlax-true) (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acActiveViewPort) ss )

This does almost what we want it to do, but I'm having trouble with draw order. Running it the first time on an MTEXT block works as expected, but running it again on a second line, the MTEXT block ends up on top of the previously drawn poly lines.

To try and solve it, I put the draworder of the TEXT to _front before using the strikethrough command on it. I figured this would put the polyline on the front layer. I don't want to change the draw order of the MTEXT.

It seems like when I use VLA-COPY, it is copying it to the front. Then my TEXT object is being brought to front after that, so that is showing in front of the MTEXT, but any previous lines are hidden as the new MTEXT object is in front of the previous polylines. Is there some caveat when using vla-copy and draw orders?

lordnk · 发表于 2022-7-5 19:26:40

Looks like I solved it, using some awesome Lee Mac code. What a guy. Pretty much what I thought, I guess the copied object was on the top of the draw order. Seems counter-intuitive to the object oriented methods of VL, though. Still getting used to this language!

Just needed to adjust the draw layer of the copied object to 'below' the original, that way after the original object was exploded & texts removed the 'copy' of the MTEXT remained in the original order. Now I guess I need to learn how to do error checking, because if you click on the wrong spot with your pick box, really bad things happen. Hah.

copy

(defun st ( / es en cp vo vc vcm vcc ex ss s ot os textCol) (setq es (entsel "\nSelect MTEXT:")       en (car es)       cp (cadr es)       vo (vlax-ename->vla-object en)       vc (vla-copy (vlax-ename->vla-object en))       vcm (LM:movebelow (list vc) vo)       vcc (vla-put-visible vc :vlax-false)       ex (vl-cmdf "explode" en)       ss (ssget "_P")       s (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))       ot (ssname (ssget cp '((0 . "TEXT"))) 0)       os (vla-get-textstring (vlax-ename->vla-object ot))       textCol "8"   ) (if ss       (progn        (vlax-for o s          (progn (setq tstr (vla-get-textstring o))                 (if (= tstr os)                              (progn                                (vl-cmdf "draworder" (vlax-vla-object->ename o) "" "_front")                         (LM:strikethrough (vlax-vla-object->ename o) '((0.0 0.1)))                         (vl-cmdf "erase" (vlax-vla-object->ename o) "")                              )                       (vl-cmdf "erase" (vlax-vla-object->ename o) "")                 )          )        )       )          ) (vla-delete s) (setq text (vl-string-subst (strcat "\\C" textCol ";" os "\\C256;") os (vla-get-textstring vc))) (vla-put-textstring vc text) (vla-put-visible vc :vlax-true) (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acActiveViewPort) ss )

[编程交流] Strike Through Text, Mtext, Le

发表回复

精选推荐