Author Topic: [wip] Explode mtext function  (Read 11631 times)

0 Members and 1 Guest are viewing this topic.

T.Willey

  • Needs a day job
  • Posts: 5218
[wip] Explode mtext function
« 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.
Code: [Select]
(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)
)
« Last Edit: July 16, 2009, 11:56:26 AM by T.Willey »
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

VVA

  • Newt
  • Posts: 166
Re: [wip] Explode mtext function
« Reply #1 on: July 10, 2009, 02:51:30 AM »
Acad 2009 have new mtext formatting. See attach.

Chris

  • Swamp Rat
  • Posts: 544
Re: [wip] Explode mtext function
« Reply #2 on: July 10, 2009, 07:55:12 AM »
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?
Christopher T. Cowgill, P.E.
AEC Collection 2018 (C3D)
Win 10

T.Willey

  • Needs a day job
  • Posts: 5218
Re: [wip] Explode mtext function
« Reply #3 on: July 10, 2009, 11:21:57 AM »
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.
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

T.Willey

  • Needs a day job
  • Posts: 5218
Re: [wip] Explode mtext function
« Reply #4 on: July 10, 2009, 11:57:10 AM »
Updated code in first post.
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

andrew_nao

  • Swamp Rat
  • Posts: 566
Re: [wip] Explode mtext function
« Reply #5 on: July 10, 2009, 02:28:54 PM »
was this idea based off the post i made for exploding mtext?

T.Willey

  • Needs a day job
  • Posts: 5218
Re: [wip] Explode mtext function
« Reply #6 on: July 10, 2009, 02:32:08 PM »
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.
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

andrew_nao

  • Swamp Rat
  • Posts: 566
Re: [wip] Explode mtext function
« Reply #7 on: July 13, 2009, 10:15:23 AM »
ill have to play around with this

thnks Tim

Chris

  • Swamp Rat
  • Posts: 544
Re: [wip] Explode mtext function
« Reply #8 on: July 14, 2009, 12:51:07 PM »
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?
Christopher T. Cowgill, P.E.
AEC Collection 2018 (C3D)
Win 10

T.Willey

  • Needs a day job
  • Posts: 5218
Re: [wip] Explode mtext function
« Reply #9 on: July 14, 2009, 01:32:41 PM »
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.
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

T.Willey

  • Needs a day job
  • Posts: 5218
Re: [wip] Explode mtext function
« Reply #10 on: July 14, 2009, 01:50:20 PM »
Updated code in first post.
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

T.Willey

  • Needs a day job
  • Posts: 5218
Re: [wip] Explode mtext function
« Reply #11 on: July 14, 2009, 02:43:25 PM »
Updated code in first post.
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

T.Willey

  • Needs a day job
  • Posts: 5218
Re: [wip] Explode mtext function
« Reply #12 on: July 15, 2009, 02:52:39 PM »
Updated code in first post.

Let me know if anyone finds this useful or not.  Please.   :-)
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10376
Re: [wip] Explode mtext function
« Reply #13 on: July 15, 2009, 03:31:52 PM »
I have no immediate need for it but I sure put a copy in my library. You never know. 8-)
I've reached the age where the happy hour is a nap. ()
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

VovKa

  • Swamp Rat
  • Posts: 1180
  • Ukraine
Re: [wip] Explode mtext function
« Reply #14 on: July 15, 2009, 04:07:34 PM »
you've engaged yourself in a serious war against autocad, Tim :)
try exploding the following
Code: [Select]
(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)
   )
)