TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: T.Willey on July 09, 2009, 05:16:14 PM
-
Here is one I just wrote. It seems to work pretty well. There is a problem when the end of the line is close to the width, but for the most part it seems to work pretty well. Right now it will remove all formatting. It will not delete the mtext object fed. It will return a list of vla-objects from top to bottom.
It's still a work in progress, so comments/suggestions/bug reports, are all welcomed. All sub's should be here.
Edit: Update code to include check for rotation of mtext.
Edit: Updated code per VVA's comments below. Included more formatting strings.
Edit: Update code. Now copies more of the mtext properties, and the spacing is improved.
Edit: Updated code. Had a small bug in it.
Edit: Updated code to deal with %%( character ) symbols, and when text width is set per style.
Edit: Updated code per Vovka's test string. Revised the RemoveAllFormatting function.
Edit: Updated code per Vovka's test string. Revised the RemoveAllFormatting function. Again
Edit: Updated code per Vovka's test string. Revised the RemoveAllFormatting function. Again. Got the alignment now.
(defun ExplodeMText ( mtObj doc / OwnerObj MtWd MtHt ll ur tempPt tempStr mtStr StPos tempNum StrsList SpList tempText tempList StyWd
WdList WdCnt EndPos StrList TxStrList InsPt flag TxObjList SpCnt MtSty RemoveAllFormating FontLetterWidth PropsList MtLnSpc ExcptList )
;(ExplodeMtext (vlax-ename->vla-object (car (entsel))) (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(defun RemoveAllFormatting ( str / Pos nStr oChar LenStr BlsBktCnt ClsBktCnt ClnCnt cChar tempPos tempStr tempChar )
;(RemoveAllFormatting (vla-get-TextString (vlax-ename->vla-object (car (entsel)))))
(setq Pos 1)
(setq nStr "")
(setq oChar "")
(setq ClsBktCnt 0)
(setq ClnCnt 0)
(while (vl-string-search "\t" str)
(setq str (vl-string-subst " " "\t" str))
)
(setq LenStr (strlen str))
(while (<= Pos LenStr)
(setq cChar (substr str Pos 1))
(cond
(
(or
(and
(= cChar "{")
(/= (strcat oChar cChar) "\\{")
)
(and
(= cChar "}")
(/= (strcat oChar cChar) "\\}")
)
)
)
(
(and
(= cChar "\\")
(= oChar "\\")
)
(setq cChar "")
)
(
(and
(= cChar "\\")
(member (setq tempChar (substr str (1+ Pos) 1)) '("p" "a" "A" "c" "C" "f" "F" "h" "H" "q" "Q" "s" "S" "t" "T" "w" "W"))
)
(if (= (strcase tempChar) "S")
(progn
(setq tempPos (vl-string-search ";" str Pos))
(setq tempStr (substr str (+ 2 Pos) (1- (- tempPos Pos))))
(setq nStr
(strcat
(if (= oChar " ")
""
" "
)
(cond
((vl-string-search "#" tempStr)
(vl-string-subst "/" "#" tempStr)
)
((vl-string-search "^" tempStr)
(vl-string-subst ", " "^" tempStr)
)
(t tempStr)
)
nStr
)
)
(setq Pos (1+ tempPos))
(setq cChar (substr str Pos 1))
)
(setq ClnCnt (1+ ClnCnt))
)
)
(
(and
(= cChar ";")
(not (zerop ClnCnt))
)
(setq ClnCnt (1- ClnCnt))
)
((member (strcat cChar (substr str (1+ Pos) 1)) '("\\L" "\\l" "\\O" "\\o"))
(setq Pos (1+ Pos))
)
(t
(if (zerop ClnCnt)
(setq nStr (strcat nStr cChar))
)
)
)
(setq Pos (1+ Pos))
(setq oChar cChar)
)
(while (vl-string-search "\\{" nStr)
(setq nStr (vl-string-subst "{" "\\{" nStr))
)
(while (vl-string-search "\\}" nStr)
(setq nStr (vl-string-subst "}" "\\}" nStr))
)
(while (vl-string-search "\~" nStr)
(setq nStr (vl-string-subst " " "\~" nStr))
)
nStr
)
;----------------------------------------------------------
(defun FontLetterWidth (Doc TextObj / MdSpc StyCol Sty FontName DictCol DictObj cnt CurLtr tempText ll ur Dist FontWidthList
WidthList StyName String TextWd TextHt StyDictObj tempStrList tempList tempStr)
; Returns a list of distances for the text string of the object supplied. The distances are that of each
; letter in the string starting from the lower left bounding box point of the text, when the text is rotated
; to 0.0 degrees.
; Idea from 'SomeCallMeDave' @ theswamp. Thanks again.
(setq StyName (vla-get-StyleName TextObj))
(setq String (vla-get-TextString TextObj))
(setq TextWd (vla-get-ScaleFactor TextObj))
(setq TextHt (vla-get-Height TextObj))
(setq TextLen (strlen String))
(setq cnt -1)
(while (setq cnt (vl-string-search "%%" String (setq cnt (1+ cnt))))
(setq tempStrList (cons (cons (1+ cnt) (setq tempStr (strcase (substr String (1+ cnt) 3)))) tempStrList))
)
(setq MdSpc (vla-get-ModelSpace Doc))
(setq StyCol (vla-get-TextStyles Doc))
(setq Sty (vla-Item StyCol StyName))
(setq FontName
(if (findfile (vla-get-fontFile Sty))
(vl-filename-base (vla-get-fontFile Sty))
(vl-filename-base (getvar "fontalt"))
)
)
;(setq DictCol (vla-get-Dictionaries Doc))
;(if (vl-catch-all-error-p (setq DictObj (vl-catch-all-apply 'vla-Item (list DictCol "MyFontWidthDict"))))
; (setq DictObj (vla-Add DictCol "MyFontWidthDict"))
;)
;(if (vl-catch-all-error-p (setq StyDictObj (vl-catch-all-apply 'vla-Item (list DictObj StyName))))
; (setq StyDictObj (vla-Add DictObj StyName))
;)
(setq cnt 1)
(while (<= cnt TextLen)
(if (setq tempList (assoc cnt tempStrList))
(progn
(setq CurLtr (cdr tempList))
(setq cnt (+ cnt 2))
)
(setq CurLtr (substr String cnt 1))
)
(if (not (assoc CurLtr FontWidthList))
(progn
(cond
((= CurLtr " ")
(setq tempText (vlax-invoke MdSpc 'AddText "AA" '(0.0 0.0 0.0) 1.0))
(vla-put-Height tempText 1.0)
(vla-put-ScaleFactor tempText 1.0)
(vla-put-StyleName tempText StyName)
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq Dist (distance (cons (car ll) (cdr ur)) ur))
(vla-put-TextString tempText (strcat "A" CurLtr "A"))
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq Dist (* TextWd (* TextHt (- (distance (cons (car ll) (cdr ur)) ur) Dist))))
(setq FontWidthList (cons (cons CurLtr Dist) FontWidthList))
(vla-Delete tempText)
)
((and (equal cnt 3) (or (= CurLtr "%%U") (= CurLtr "%%O")))
(setq tempText (vlax-invoke MdSpc 'AddText "A" '(0.0 0.0 0.0) 1.0))
(vla-put-Height tempText 1.0)
(vla-put-ScaleFactor tempText 1.0)
(vla-put-StyleName tempText StyName)
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq tempPt (cons (car ll) (cdr ur)))
(vla-put-TextString tempText (strcat CurLtr "A"))
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq Dist (* TextWd (* TextHt (distance (cons (car ll) (cdr ur)) tempPt))))
(setq FontWidthList (cons (cons CurLtr Dist) FontWidthList))
(vla-Delete tempText)
)
(T
(setq tempText (vlax-invoke MdSpc 'AddText CurLtr '(0.0 0.0 0.0) 1.0))
(vla-put-Height tempText 1.0)
(vla-put-ScaleFactor tempText 1.0)
(vla-put-StyleName tempText StyName)
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq Dist (distance (cons (car ll) (cdr ur)) ur))
(vla-put-TextString tempText (strcat CurLtr CurLtr))
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq Dist (* TextWd (* TextHt (- (distance (cons (car ll) (cdr ur)) ur) Dist))))
(setq FontWidthList (cons (cons CurLtr Dist) FontWidthList))
(vla-Delete tempText)
)
)
)
)
(if (and (not (equal cnt 3)) (or (= CurLtr "%%U") (= CurLtr "%%O")))
(repeat 3
(setq WidthList (cons 0.0 WidthList))
)
(if (or (= CurLtr "%%U") (= CurLtr "%%O"))
(repeat 3
(setq WidthList (cons (/ (cdr (assoc CurLtr FontWidthList)) 3.0) WidthList))
)
(setq WidthList (cons (cdr (assoc CurLtr FontWidthList)) WidthList))
)
)
(setq cnt (1+ cnt))
)
;(print FontWidthList)
(list (reverse WidthList) tempStrList)
)
;---------------------------------------------------------------
(setq OwnrObj (vlax-invoke doc 'ObjectIdToObject (vla-get-OwnerId mtObj)))
(setq MtWd (vla-get-Width mtObj))
(setq MtHt (vla-get-Height mtObj))
(setq MtSty (vla-get-StyleName mtObj))
(setq MtRot (vla-get-Rotation mtObj))
(setq MtLnSpc (vla-get-LineSpacingDistance mtObj))
(setq StyWd (vla-get-Width (vla-Item (vla-get-TextStyles doc) (vla-get-StyleName mtObj))))
(setq PropsList
(cons
(cons "ScaleFactor" StyWd)
(mapcar
(function
(lambda ( x )
(cons x (vlax-get mtObj x))
)
)
'("Color" "Layer" "Linetype" "LinetypeScale" "Lineweight" "Normal" "PlotStyleName" "Rotation" "TrueColor")
)
)
)
(setq tempStr (RemoveAllFormatting (setq mtStr (vla-get-TextString mtObj))))
(setq StPos 1)
(setq tempNum 0)
(while (setq tempNum (vl-string-search "\\P" tempStr tempNum))
(setq StrsList
(cons
(if (> StPos tempNum)
""
(substr tempStr StPos (1+ (- tempNum StPos)))
)
StrsList
)
)
(setq StPos (1+ (setq tempNum (+ 2 tempNum))))
)
(setq StrsList (cons (substr tempStr StPos) StrsList))
(foreach str StrsList
(setq tempNum 0)
(setq SpList nil)
(while (setq tempNum (vl-string-search " " str tempNum))
(setq SpList (cons tempNum SpList))
(setq tempNum (1+ tempNum))
)
(setq SpList (reverse SpList))
(setq tempText (vlax-invoke OwnrObj 'AddText str '(0. 0. 0.) MtHt))
(vla-put-StyleName tempText MtSty)
(vla-put-ScaleFactor tempText StyWd)
(setq tempList (FontLetterWidth doc tempText))
(setq WdList (car tempList))
(setq ExcptList (cadr tempList))
(setq StPos 1)
(setq WdCnt 0)
(setq SpCnt 0)
(while (<= StPos (strlen str))
(setq tempWd 0)
(setq EndPos 1)
(while
(and
(< WdCnt (length WdList))
(<= (setq tempWd (+ tempWd (nth WdCnt WdList))) MtWd)
)
(setq WdCnt (1+ WdCnt))
(setq EndPos
(if (setq tempList (assoc WdCnt ExcptList))
(+ (1- (strlen (cdr tempList))) EndPos)
(1+ EndPos)
)
)
)
(setq tempNum
(if SpList
(nth SpCnt SpList)
-1
)
)
(while
(and
(< SpCnt (length SpList))
(> (1- (+ StPos EndPos)) (nth SpCnt SpList))
)
(setq tempNum (nth SpCnt SpList))
(setq SpCnt (1+ SpCnt))
)
(if
(and
(< tempWd MtWd)
(or
(>= SpCnt (length SpList))
(>= WdCnt (length WdList))
)
)
(setq tempNum (strlen str))
)
(setq StrList
(cons
(substr
str
StPos
(if (< tempNum StPos)
(setq tempNum (+ StPos EndPos))
(- (1+ tempNum) StPos)
)
)
StrList
)
)
(setq StPos (+ 2 tempNum))
(setq WdCnt StPos)
)
(setq TxStrList (cons (reverse StrList) TxStrList))
(setq StrList nil)
(vla-Delete tempText)
)
(setq InsPt '(0. 0. 0.))
(foreach lst TxStrList
(if lst
(foreach str lst
(print str)
(setq TxObjList (cons (setq tempText (vlax-invoke OwnrObj 'AddText str InsPt MtHt)) TxObjList))
(vla-put-StyleName tempText MtSty)
(if (not flag)
(progn
(setq tempMtObj (vlax-invoke mtObj 'Copy))
(vla-put-Rotation tempMtObj 0.)
(vla-GetBoundingBox tempMtObj 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq AtchPt (vla-get-AttachmentPoint mtObj))
(setq tempPt
(list
(cond
((member AtchPt '(1 4 7))
(setq Ali 0)
(car ll)
)
((member AtchPt '(2 5 8))
(setq Ali 4)
(* (+ (car ll) (car ur)) 0.5)
)
((member AtchPt '(3 6 9))
(setq Ali 2)
(car ur)
)
)
(cadr ur)
(caddr ll)
)
)
(vla-put-Alignment tempText Ali)
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(vlax-invoke
tempText
'Move
(list
(cond
((member AtchPt '(1 4 7))
(car ll)
)
((member AtchPt '(2 5 8))
(* (+ (car ll) (car ur)) 0.5)
)
((member AtchPt '(3 6 9))
(car ur)
)
)
(cadr ur)
(caddr ll)
)
tempPt
)
(vlax-invoke tempText 'Rotate (vlax-get tempMtObj 'InsertionPoint) MtRot)
(setq InsPt
(if (equal Ali 0)
(vlax-get tempText 'InsertionPoint)
(vlax-get tempText 'TextAlignmentPoint)
)
)
(setq PropsList (cons (cons "Alignment" Ali) PropsList))
(setq flag T)
(vla-Delete tempMtObj)
)
)
(foreach i PropsList
(vl-catch-all-apply 'vlax-put (list TempText (car i) (cdr i)))
)
(vlax-put tempText (if (equal Ali 0) "InsertionPoint" "TextAlignmentPoint") InsPt)
(setq InsPt (polar InsPt (rem (+ MtRot (* pi 1.5)) (* pi 2.)) MtLnSpc))
)
(setq InsPt (polar InsPt (rem (+ MtRot (* pi 1.5)) (* pi 2.)) MtLnSpc))
)
)
(reverse TxObjList)
)
-
Acad 2009 have new mtext formatting. See attach.
-
Acad 2009 have new mtext formatting. See attach.
I only perused your code Tim, it looks quite extensive. VVA are you referring to the vertical spacing of the lines of text? If so, I believe the formatting change took place in AutoCAD 2008, with the introduction of annotative text and multileaders. The formula is a little more complex.
Tim, maybe I dont understand what your code is accomplishing, why not use the explode command?
-
Thanks for the tip VVA. I did the coding for '06, and didn't know about the new formatting strings. I can look into this, as I don't think it will be too hard to add to the function.
Chris,
This was in one way, a way to exercise the grey matter, and in another way, a way to give people what they ask for. People here like to use code when they code, and if you have to explode mtext through code, then you would have to use the command, this way you don't have to use any command calls.
-
Updated code in first post.
-
was this idea based off the post i made for exploding mtext?
-
was this idea based off the post i made for exploding mtext?
Yours was just one last thread that people voiced their opinion about wanting a function to explode mtext, so I thought I would take up the challenge. I've heard this for years, but never took the time to write one, and neither have I found one.
-
ill have to play around with this
thnks Tim
-
Thanks for the tip VVA. I did the coding for '06, and didn't know about the new formatting strings. I can look into this, as I don't think it will be too hard to add to the function.
Chris,
This was in one way, a way to exercise the grey matter, and in another way, a way to give people what they ask for. People here like to use code when they code, and if you have to explode mtext through code, then you would have to use the command, this way you don't have to use any command calls.
that makes sense, in other words, if you were trying to use a reactor, you could use this code to explode the mtext as you shouldn't use commands in reactors, or is this still blowing totally over my head?
-
Thanks for the tip VVA. I did the coding for '06, and didn't know about the new formatting strings. I can look into this, as I don't think it will be too hard to add to the function.
Chris,
This was in one way, a way to exercise the grey matter, and in another way, a way to give people what they ask for. People here like to use code when they code, and if you have to explode mtext through code, then you would have to use the command, this way you don't have to use any command calls.
that makes sense, in other words, if you were trying to use a reactor, you could use this code to explode the mtext as you shouldn't use commands in reactors, or is this still blowing totally over my head?
Nope. That could be one use. This should also explode in other spaces besides the current one, and within blocks. Also could be used with ObjectDBX. Would need to be tested, but in theory it should work.
-
Updated code in first post.
-
Updated code in first post.
-
Updated code in first post.
Let me know if anyone finds this useful or not. Please. :-)
-
I have no immediate need for it but I sure put a copy in my library. You never know. 8-)
-
you've engaged yourself in a serious war against autocad, Tim :)
try exploding the following
(entmake
'((0 . "MTEXT")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(100 . "AcDbMText")
(10 4.95976 183.616 0.0)
(40 . 2.5)
(41 . 34.6637)
(71 . 1)
(72 . 5)
(1
.
"{\\fArial|b0|i0|c204|p34;my name is \\fArial|b0|i1|c0|p34;VovKa\\P\\fArial|b0|i0|c0|p34;\\H2x;hello}"
)
(7 . "Standard")
(210 0.0 0.0 1.0)
(11 1.0 0.0 0.0)
(42 . 28.7364)
(43 . 9.24852)
(50 . 0.0)
(73 . 1)
(44 . 1.0)
)
)
-
I knew those nested format codes would get me. I guess I can go for them next. Thanks for the example Vovka. I don't use mtext, so I don't know how much trouble I was getting into. Now I know, and I'm scared. I'll see what I can do.
-
May be of some help.
http://www.theswamp.org/index.php?topic=7272.0
-
Updated code in first post.
May be of some help.
http://www.theswamp.org/index.php?topic=7272.0
Thanks Alan. Will take a look and see how you did it.
-
And another to look at.
http://www.theswamp.org/index.php?topic=17185.msg207578#msg207578
-
and more to think over
(entmake
'((0 . "MTEXT")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(100 . "AcDbMText")
(10 20.5909 157.984 0.0)
(40 . 2.5)
(41 . 59.0253)
(71 . 8)
(72 . 5)
(1
.
"{\\fArial|b0|i0|c204|p34;my name is \\fArial|b0|i1|c0|p34;VovKa\\P\\pt17.5;\\fArial|b0|i0|c0|p34;\\H2x;\t\\\\hello\\\\}"
)
(7 . "Standard")
(210 0.0 0.0 1.0)
(11 1.0 0.0 0.0)
(42 . 36.1392)
(43 . 13.5039)
(50 . 0.0)
(73 . 1)
(44 . 2.0)
)
)
-
VovKa,
What does the p34 do/mean?
*just curious*
Lee
-
Lee Mac, i guess it's telling that the font is unicode.
-
I'm almost there Vovka. :wink:
-
Updated code in first post. :-)
-
Spoke a little too soon. I got the part I thought I needed to get, and didn't realize that you change the alignment of the text. I will have to see if I can get to that issue tomorrow.
Nice touch there Vovka. Sneaky like a ninja.
-
sounds like it's time to use the c#NET MText.ExplodeFragments method in a wrapper for Lisp :)
///kdub
-
The Tab isn't recognised yet ..
-
I was looking at other stuff to write wrappers for also, but didn't know where to start. This might be a good one to start with. Thanks for the idea Kerry. Sucks about the Tab though.
-
Updated code in first post.
-
stab in the back :)
(entmake
'((0 . "MTEXT")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "0")
(100 . "AcDbMText")
(10 198.152 203.61 0.0)
(40 . 2.5)
(41 . 53.7689)
(71 . 5)
(72 . 5)
(1
.
"\\pi-7.5,l7.5,t30;{\\fArial|b0|i0|c0|p34;test\\\\test\t\\H0.6878x;\\Stest/test;\\H1.454x; \\P\\pi-17.5,l17.5;\\P \\\\test}"
)
(7 . "Standard")
(210 0.0 0.0 1.0)
(11 1.0 0.0 0.0)
(42 . 97.7908)
(43 . 6.33333)
(50 . 0.0)
(73 . 2)
(44 . 0.36)
)
)
even "EXPLODE" command cannot get it right
-
For those following along, I think this version one ups the command explode and mtext. If you explode mtext that is isn't left justified, it will line up the text correctly, but will make the text left justified, but with my explode method, it will keep the justification either left, middle or right, so that it is truly lined up. Just an FYI for those following along. We now return you back to your regularly scheduled program.
-
you are close Tim.
still you get this when using tabs on the mtx.-
-
I'll see what I can do about that Luis.
And Vovka, I will see what I can do about that also. The fraction is the problem.
-
Tim,
I'll probably just need to substitute spaced for the tabs before I do the mojo on the string from net.
.. homework for the weekend
also homework .. is there any way to determine the no. of characters shifted by a tab ????
-
Tim,
I'll probably just need to substitute spaced for the tabs before I do the mojo on the string from net.
.. homework for the weekend
also homework .. is there any way to determine the no. of characters shifted by a tab ????
Not that I know of ( was wondering the same thing ). I'm not even sure where it would be located. If it's an Acad thing, or a font/shx file thing. Right now I just place four spaces per tab.
-
I was able to do this:
*** Command: XMT
*** (ExplodeMText <ename>) Return T or Nil
Command: XMT
Select a mtext entity:
(ExplodeMText (car (entsel "\nSelect a mtext: ")))
Attached it is a debug objectARX file for AutoCAD 2007 to 2009
-
Luis,
Is there any special reason why you don't post your code ???
Regards,
Kerry
-
I was able to do this:
*** Command: XMT
*** (ExplodeMText <ename>) Return T or Nil
Command: XMT
Select a mtext entity:
(ExplodeMText (car (entsel "\nSelect a mtext: ")))
Attached it is a debug objectARX file for AutoCAD 2007 to 2009
Wow Luis! It even worked great on that last one by Vovka. But it only explodes the text to model space. I tried it on an mtext object in paper space, but the text was inserted into model space, and put it on layer 0. Still impressive though. Dang ObjectARX. :cry:
-
Wow Luis! It even worked great on that last one by Vovka. But it only explodes the text to model space. I tried it on an mtext object in paper space, but the text was inserted into model space, and put it on layer 0. Still impressive though. Dang ObjectARX. :cry:
It was just a quicky one... simple implementation of AcDbMTextFragment structure, was going to do these other properties like: italic and bold, underline, overline.... but it is to much :)
-
Wow Luis! It even worked great on that last one by Vovka. But it only explodes the text to model space. I tried it on an mtext object in paper space, but the text was inserted into model space, and put it on layer 0. Still impressive though. Dang ObjectARX. :cry:
It was just a quicky one... simple implementation of AcDbMTextFragment structure, was going to do these other properties like: italic and bold, underline, overline.... but it is to much :)
Cool still though. :-)
-
Luis,
Is there any special reason why you don't post your code ???
Regards,
Kerry
Nothing special at all, I was able to work a little more on the project and it is now (the ObjectARX source) here:
http://www.theswamp.org/index.php?topic=29544.new#new
HTH
Luis.
-
Thanks Luis,
that's more in line with the philosophy of the forum. :-)
-
Re the tabs and spaces,
The short answer is
"it depends .. "
(3 . "x using Arial \\Px\ttab\\Px 4 spaces\\P\\P{\\Fisocp|c0;
x using isocp\\Px\ttab\\Px 4 spaces\\P\\P\\fAndale Mono|b0|i0|c0|p49;
x using Andale Mono\\Px \ttab\\Px 4 spaces\\P\\P\\Fromans|c0;
x using romans\\Px \ttab\\Px 4 spaces\\P\\P\\fBitstream Vera Sans Mono|b0|i0|")(1 . "c0|p49;
x using Bitstream Vera Mono\\Px \ttab\\Px 4 spaces\\P\\P\\Ftxt|c0;x using txt\\Px \ttab\\Px 4 spaces}")
-
First of all, thanks for the work on this code. The ability to explode mtext inside of blocks is an extremely nice feature. Unfortunately, I think there is a problem with how this program handles text with a width of 0. When the dxf code 41 is 0, it seems to split the string incorrectly. Here is an example:
(entmake
'((0 . "MTEXT")
(100 . "AcDbEntity")
(67 . 0) (410 . "Model")
(8 . "0")
(100 . "AcDbMText")
(10 0.0 0.0 0.0)
(40 . 0.15625)
(41 . 0.0)
(46 . 0.0)
(71 . 7)
(72 . 1)
(1
.
"\\fMyriad Roman|b0|i0|c0|p34;\\W1;realLy_longwordtestsTring"
)
(7 . "Standard")
(210 0.0 0.0 1.0)
(11 1.0 0.0 0.0)
(42 . 0.550595)
(43 . 0.15625)
(50 . 0.0)
(73 . 1)
(44 . 1.0)
)
)
_$ (EXPLODEMTEXT (vlax-ename->vla-object (ssname (ssget) 0)) (vla-get-activedocument (vlax-get-acad-object)))
"re"
"lLy_l"
"_longwor"
"ngwordtests"
"ordtestsTring"
"testsTring"
"tsTring"
"ring"
"g" (#<VLA-OBJECT IAcadText2 246ff0ac> #<VLA-OBJECT IAcadText2 2470892c> #<VLA-OBJECT IAcadText2 246fc82c> #<VLA-OBJECT IAcadText2 2470a02c> #<VLA-OBJECT IAcadText2 247065ac> #<VLA-OBJECT IAcadText2 246fc92c> #<VLA-OBJECT IAcadText2 246ff52c> #<VLA-OBJECT IAcadText2 2470592c> #<VLA-OBJECT IAcadText2 2470642c>)
_$
Strings containing spaces and having a dxf code 41 = 0 also are split incorrectly see:
(entmake
'((0 . "MTEXT")
(100 . "AcDbEntity")
(67 . 0) (410 . "Model")
(8 . "0")
(100 . "AcDbMText")
(10 0.0 0.0 0.0)
(40 . 0.15625)
(41 . 0.0)
(46 . 0.0)
(71 . 7)
(72 . 1)
(1
.
"\\fMyriad Roman|b0|i0|c0|p34;\\W1;test STring with spaces"
)
(7 . "Standard")
(210 0.0 0.0 1.0)
(11 1.0 0.0 0.0)
(42 . 0.550595)
(43 . 0.15625)
(50 . 0.0)
(73 . 1)
(44 . 1.0)
)
)
_$ (EXPLODEMTEXT (vlax-ename->vla-object (ssname (ssget) 0)) (vla-get-activedocument (vlax-get-acad-object)))
"test"
"STring "
"ing"
"with spaces"
"h"
"spaces"
"ces" (#<VLA-OBJECT IAcadText2 2470a7ac> #<VLA-OBJECT IAcadText2 246fffac> #<VLA-OBJECT IAcadText2 2470402c> #<VLA-OBJECT IAcadText2 247002ac> #<VLA-OBJECT IAcadText2 24701aac> #<VLA-OBJECT IAcadText2 247037ac> #<VLA-OBJECT IAcadText2 246fe4ac>)
_$
Thanks.
gotnone
-
I made a change to fix the case for zero width mtext entities. It seems to handle long strings with and without spaces correctly. I am not sure that it didn't break other cases, but I offer it for others anyway.
(defun ExplodeMText ( mtObj doc / OwnerObj MtWd MtHt ll ur tempPt tempStr mtStr StPos tempNum StrsList SpList tempText tempList StyWd
WdList WdCnt EndPos StrList TxStrList InsPt flag TxObjList SpCnt MtSty RemoveAllFormating FontLetterWidth PropsList MtLnSpc ExcptList )
;(ExplodeMtext (vlax-ename->vla-object (car (entsel))) (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(defun RemoveAllFormatting ( str / Pos nStr oChar LenStr BlsBktCnt ClsBktCnt ClnCnt cChar tempPos tempStr tempChar )
;(RemoveAllFormatting (vla-get-TextString (vlax-ename->vla-object (car (entsel)))))
(setq Pos 1)
(setq nStr "")
(setq oChar "")
(setq ClsBktCnt 0)
(setq ClnCnt 0)
(while (vl-string-search "\t" str)
(setq str (vl-string-subst " " "\t" str))
)
(setq LenStr (strlen str))
(while (<= Pos LenStr)
(setq cChar (substr str Pos 1))
(cond
(
(or
(and
(= cChar "{")
(/= (strcat oChar cChar) "\\{")
)
(and
(= cChar "}")
(/= (strcat oChar cChar) "\\}")
)
)
)
(
(and
(= cChar "\\")
(= oChar "\\")
)
(setq cChar "")
)
(
(and
(= cChar "\\")
(member (setq tempChar (substr str (1+ Pos) 1)) '("p" "a" "A" "c" "C" "f" "F" "h" "H" "q" "Q" "s" "S" "t" "T" "w" "W"))
)
(if (= (strcase tempChar) "S")
(progn
(setq tempPos (vl-string-search ";" str Pos))
(setq tempStr (substr str (+ 2 Pos) (1- (- tempPos Pos))))
(setq nStr
(strcat
(if (= oChar " ")
""
" "
)
(cond
((vl-string-search "#" tempStr)
(vl-string-subst "/" "#" tempStr)
)
((vl-string-search "^" tempStr)
(vl-string-subst ", " "^" tempStr)
)
(t tempStr)
)
nStr
)
)
(setq Pos (1+ tempPos))
(setq cChar (substr str Pos 1))
)
(setq ClnCnt (1+ ClnCnt))
)
)
(
(and
(= cChar ";")
(not (zerop ClnCnt))
)
(setq ClnCnt (1- ClnCnt))
)
((member (strcat cChar (substr str (1+ Pos) 1)) '("\\L" "\\l" "\\O" "\\o"))
(setq Pos (1+ Pos))
)
(t
(if (zerop ClnCnt)
(setq nStr (strcat nStr cChar))
)
)
)
(setq Pos (1+ Pos))
(setq oChar cChar)
)
(while (vl-string-search "\\{" nStr)
(setq nStr (vl-string-subst "{" "\\{" nStr))
)
(while (vl-string-search "\\}" nStr)
(setq nStr (vl-string-subst "}" "\\}" nStr))
)
(while (vl-string-search "\~" nStr)
(setq nStr (vl-string-subst " " "\~" nStr))
)
nStr
)
;----------------------------------------------------------
(defun FontLetterWidth (Doc TextObj / MdSpc StyCol Sty FontName DictCol DictObj cnt CurLtr tempText ll ur Dist FontWidthList
WidthList StyName String TextWd TextHt StyDictObj tempStrList tempList tempStr)
; Returns a list of distances for the text string of the object supplied. The distances are that of each
; letter in the string starting from the lower left bounding box point of the text, when the text is rotated
; to 0.0 degrees.
; Idea from 'SomeCallMeDave' @ theswamp. Thanks again.
(setq StyName (vla-get-StyleName TextObj))
(setq String (vla-get-TextString TextObj))
(setq TextWd (vla-get-ScaleFactor TextObj))
(setq TextHt (vla-get-Height TextObj))
(setq TextLen (strlen String))
(setq cnt -1)
(while (setq cnt (vl-string-search "%%" String (setq cnt (1+ cnt))))
(setq tempStrList (cons (cons (1+ cnt) (setq tempStr (strcase (substr String (1+ cnt) 3)))) tempStrList))
)
(setq MdSpc (vla-get-ModelSpace Doc))
(setq StyCol (vla-get-TextStyles Doc))
(setq Sty (vla-Item StyCol StyName))
(setq FontName
(if (findfile (vla-get-fontFile Sty))
(vl-filename-base (vla-get-fontFile Sty))
(vl-filename-base (getvar "fontalt"))
)
)
;(setq DictCol (vla-get-Dictionaries Doc))
;(if (vl-catch-all-error-p (setq DictObj (vl-catch-all-apply 'vla-Item (list DictCol "MyFontWidthDict"))))
; (setq DictObj (vla-Add DictCol "MyFontWidthDict"))
;)
;(if (vl-catch-all-error-p (setq StyDictObj (vl-catch-all-apply 'vla-Item (list DictObj StyName))))
; (setq StyDictObj (vla-Add DictObj StyName))
;)
(setq cnt 1)
(while (<= cnt TextLen)
(if (setq tempList (assoc cnt tempStrList))
(progn
(setq CurLtr (cdr tempList))
(setq cnt (+ cnt 2))
)
(setq CurLtr (substr String cnt 1))
)
(if (not (assoc CurLtr FontWidthList))
(progn
(cond
((= CurLtr " ")
(setq tempText (vlax-invoke MdSpc 'AddText "AA" '(0.0 0.0 0.0) 1.0))
(vla-put-Height tempText 1.0)
(vla-put-ScaleFactor tempText 1.0)
(vla-put-StyleName tempText StyName)
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq Dist (distance (cons (car ll) (cdr ur)) ur))
(vla-put-TextString tempText (strcat "A" CurLtr "A"))
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq Dist (* TextWd (* TextHt (- (distance (cons (car ll) (cdr ur)) ur) Dist))))
(setq FontWidthList (cons (cons CurLtr Dist) FontWidthList))
(vla-Delete tempText)
)
((and (equal cnt 3) (or (= CurLtr "%%U") (= CurLtr "%%O")))
(setq tempText (vlax-invoke MdSpc 'AddText "A" '(0.0 0.0 0.0) 1.0))
(vla-put-Height tempText 1.0)
(vla-put-ScaleFactor tempText 1.0)
(vla-put-StyleName tempText StyName)
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq tempPt (cons (car ll) (cdr ur)))
(vla-put-TextString tempText (strcat CurLtr "A"))
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq Dist (* TextWd (* TextHt (distance (cons (car ll) (cdr ur)) tempPt))))
(setq FontWidthList (cons (cons CurLtr Dist) FontWidthList))
(vla-Delete tempText)
)
(T
(setq tempText (vlax-invoke MdSpc 'AddText CurLtr '(0.0 0.0 0.0) 1.0))
(vla-put-Height tempText 1.0)
(vla-put-ScaleFactor tempText 1.0)
(vla-put-StyleName tempText StyName)
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq Dist (distance (cons (car ll) (cdr ur)) ur))
(vla-put-TextString tempText (strcat CurLtr CurLtr))
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq Dist (* TextWd (* TextHt (- (distance (cons (car ll) (cdr ur)) ur) Dist))))
(setq FontWidthList (cons (cons CurLtr Dist) FontWidthList))
(vla-Delete tempText)
)
)
)
)
(if (and (not (equal cnt 3)) (or (= CurLtr "%%U") (= CurLtr "%%O")))
(repeat 3
(setq WidthList (cons 0.0 WidthList))
)
(if (or (= CurLtr "%%U") (= CurLtr "%%O"))
(repeat 3
(setq WidthList (cons (/ (cdr (assoc CurLtr FontWidthList)) 3.0) WidthList))
)
(setq WidthList (cons (cdr (assoc CurLtr FontWidthList)) WidthList))
)
)
(setq cnt (1+ cnt))
)
;(print FontWidthList)
(list (reverse WidthList) tempStrList)
)
;---------------------------------------------------------------
(setq OwnrObj (vlax-invoke doc 'ObjectIdToObject (vla-get-OwnerId mtObj)))
(setq MtWd (vla-get-Width mtObj))
(setq MtHt (vla-get-Height mtObj))
(setq MtSty (vla-get-StyleName mtObj))
(setq MtRot (vla-get-Rotation mtObj))
(setq MtLnSpc (vla-get-LineSpacingDistance mtObj))
(setq StyWd (vla-get-Width (vla-Item (vla-get-TextStyles doc) (vla-get-StyleName mtObj))))
(setq PropsList
(cons
(cons "ScaleFactor" StyWd)
(mapcar
(function
(lambda ( x )
(cons x (vlax-get mtObj x))
)
)
'("Color" "Layer" "Linetype" "LinetypeScale" "Lineweight" "Normal" "PlotStyleName" "Rotation" "TrueColor")
)
)
)
(setq tempStr (RemoveAllFormatting (setq mtStr (vla-get-TextString mtObj))))
(setq StPos 1)
(setq tempNum 0)
(while (setq tempNum (vl-string-search "\\P" tempStr tempNum))
(setq StrsList
(cons
(if (> StPos tempNum)
""
(substr tempStr StPos (1+ (- tempNum StPos)))
)
StrsList
)
)
(setq StPos (1+ (setq tempNum (+ 2 tempNum))))
)
(setq StrsList (cons (substr tempStr StPos) StrsList))
(foreach str StrsList
(setq tempNum 0)
(setq SpList nil)
(while (setq tempNum (vl-string-search " " str tempNum))
(setq SpList (cons tempNum SpList))
(setq tempNum (1+ tempNum))
)
(setq SpList (reverse SpList))
(setq tempText (vlax-invoke OwnrObj 'AddText str '(0. 0. 0.) MtHt))
(vla-put-StyleName tempText MtSty)
(vla-put-ScaleFactor tempText StyWd)
(setq tempList (FontLetterWidth doc tempText))
(setq WdList (car tempList))
(setq ExcptList (cadr tempList))
(setq StPos 1)
(setq WdCnt 0)
(setq SpCnt 0)
(while (<= StPos (strlen str))
(setq tempWd 0)
(setq EndPos 1)
(while
(and
(< WdCnt (length WdList))
(<= (setq tempWd (+ tempWd (nth WdCnt WdList))) MtWd)
)
(setq WdCnt (1+ WdCnt))
(setq EndPos
(if (setq tempList (assoc WdCnt ExcptList))
(+ (1- (strlen (cdr tempList))) EndPos)
(1+ EndPos)
)
)
)
(setq tempNum
(if SpList
(nth SpCnt SpList)
-1
)
)
(while
(and
(< SpCnt (length SpList))
(> (1- (+ StPos EndPos)) (nth SpCnt SpList))
)
(setq tempNum (nth SpCnt SpList))
(setq SpCnt (1+ SpCnt))
)
(if
(or
(and
(< tempWd MtWd)
(or
(>= SpCnt (length SpList))
(>= WdCnt (length WdList))
)
)
(zerop MtWd)
)
(setq tempNum (strlen str))
)
(setq StrList
(cons
(substr
str
StPos
(if (< tempNum StPos)
(setq tempNum (+ StPos EndPos))
(- (1+ tempNum) StPos)
)
)
StrList
)
)
(setq StPos (+ 2 tempNum))
(setq WdCnt StPos)
)
(setq TxStrList (cons (reverse StrList) TxStrList))
(setq StrList nil)
(vla-Delete tempText)
)
(setq InsPt '(0. 0. 0.))
(foreach lst TxStrList
(if lst
(foreach str lst
(print str)
(setq TxObjList (cons (setq tempText (vlax-invoke OwnrObj 'AddText str InsPt MtHt)) TxObjList))
(vla-put-StyleName tempText MtSty)
(if (not flag)
(progn
(setq tempMtObj (vlax-invoke mtObj 'Copy))
(vla-put-Rotation tempMtObj 0.)
(vla-GetBoundingBox tempMtObj 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(setq AtchPt (vla-get-AttachmentPoint mtObj))
(setq tempPt
(list
(cond
((member AtchPt '(1 4 7))
(setq Ali 0)
(car ll)
)
((member AtchPt '(2 5 8))
(setq Ali 4)
(* (+ (car ll) (car ur)) 0.5)
)
((member AtchPt '(3 6 9))
(setq Ali 2)
(car ur)
)
)
(cadr ur)
(caddr ll)
)
)
(vla-put-Alignment tempText Ali)
(vla-GetBoundingBox tempText 'll 'ur)
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(vlax-invoke
tempText
'Move
(list
(cond
((member AtchPt '(1 4 7))
(car ll)
)
((member AtchPt '(2 5 8))
(* (+ (car ll) (car ur)) 0.5)
)
((member AtchPt '(3 6 9))
(car ur)
)
)
(cadr ur)
(caddr ll)
)
tempPt
)
(vlax-invoke tempText 'Rotate (vlax-get tempMtObj 'InsertionPoint) MtRot)
(setq InsPt
(if (equal Ali 0)
(vlax-get tempText 'InsertionPoint)
(vlax-get tempText 'TextAlignmentPoint)
)
)
(setq PropsList (cons (cons "Alignment" Ali) PropsList))
(setq flag T)
(vla-Delete tempMtObj)
)
)
(foreach i PropsList
(vl-catch-all-apply 'vlax-put (list TempText (car i) (cdr i)))
)
(vlax-put tempText (if (equal Ali 0) "InsertionPoint" "TextAlignmentPoint") InsPt)
(setq InsPt (polar InsPt (rem (+ MtRot (* pi 1.5)) (* pi 2.)) MtLnSpc))
)
(setq InsPt (polar InsPt (rem (+ MtRot (* pi 1.5)) (* pi 2.)) MtLnSpc))
)
)
(reverse TxObjList)
)
Thanks go out to T.Willey and everyone else who has contributed to this excellent script.
gotnone
-
Hi,Tim
When I use your ExplodeMText function to deal with some mtexts, several texts have been made but they didn't appear at the same location with the original mtexts.
I will be very grateful if you can reply this question..
Sorry for my bad English.
See attachments,please.
Xia
-
I have not worked/used this code since I wrote it back in '09, so I do not think I will be trying to update it. Sorry Xia. Maybe the code posted by GotNone will work, as they updated it in '12. Here is the post I'm talking about:
http://www.theswamp.org/index.php?topic=29430.msg463814#msg463814
-
I have not worked/used this code since I wrote it back in '09, so I do not think I will be trying to update it. Sorry Xia. Maybe the code posted by GotNone will work, as they updated it in '12. Here is the post I'm talking about:
http://www.theswamp.org/index.php?topic=29430.msg463814#msg463814
I'm sorry for that the code posted by GotNone had the same problem.
Thanks for reply,Tim. I'll try my best to resolve this problem myself.
Regards, Xia.