Jump to content

help with extracting text from one dimension....


leonucadomi

Recommended Posts

hello :

 

I had a routine that did this but I lost it  :(

 

1.- I need to select a dimension

2.- then a text will be created with the style and size of the selected dimension

3.- that text will move from the center point to where the user determines

 

like exploding the dimension and moving the text to another place but not exploding it

 

 

 

 

 

image.png

test.dwg

Link to comment
Share on other sites

This is the quick and dirty version. no error handling.

 

  • Copies the whole dimension to the new location.
  • Explodes the copied dimension
  • Erases everything but the MTEXT
  • Explodes Mtext into text don't know if it keeps its style? seems to.

 

;;----------------------------------------------------------------------------;;
;; Copy dimension value to another location
(defun C:DimCopy (/ dim BP LastEnt  en)
  (vl-load-com)
  (while (setq dim (car (entsel "\nSelect Dimension: ")))
    (setq dim (vlax-ename->vla-object dim))
    (setq BP (vlax-get dim 'TextPosition))
    (setq LastEnt (entlast))
    (setq copy (vla-copy dim))
    (vla-move copy BP (getpoint BP "\nCopy locaiton"))
    (command "_Explode" (entlast))
    (if (setq en (entnext LastEnt))
      (while en
        (cond
          ((= "MTEXT" (cdr (assoc 0 (entget en))))
            (command "_Explode" en) ;convert mtext to text
          )
          ((= "TEXT" (cdr (assoc 0 (entget en))))
            (progn)
          )
          (t
            (entdel en)
          )          
        )
        (setq en (entnext en))
      )
    )      
  )
  (princ)
)

 

Edited by mhupp
  • Like 2
Link to comment
Share on other sites

-EDIT- I was going at this the other way to Mhupp, get the information from the dimension and them make new text, many ways to do the same thing-

 

You can get the text itself if you use

 

(setq MyDim (entget (car (entsel "Select Dimension"))))

 

which gives an associated list of the dimension entity stuff.

 

In this list number 1 gives Text Override value and 42 gives the measured value

 

(setq TextOverride (cdr (assoc 1 MyDim)))
(setq MyDimValue (cdr (assoc 42 MyDim)))

 

you might have to decide if you need to use text override values or just the measured dimension, and note here that if the text override text contains <> this means it will show the measured dimension there... so will need to take into account that as well. I think there is a chance that in a very very long text override code 304 will take any overspill from code 1.. but I'd be surprised if you need to consider that (also 172 and 4 but I can't remember why I made a note of them)

 

 

So onto the text styles, these are not saved in the dimension but in the dimension style and I think you have to do a little more work to get them

 

(setq DimStyleName (cdr (assoc 3 MyDim)))

 

will give you the dim style name and you can do a table search to get the dim style definition:

 

(setq DimstyleDefinition (tblsearch "DIMSTYLE" DimStyleName))

 

 

However I will have to come back to this to get the next part for you - should be sometihng there for you to think about and start you off making something up, at least getting the text to start with

 

 

--EDIT--

This will give you the text style name, though this is for the dimension style used and not any over ride the user might change to

 

(setq DimTxtEntity (entget (cdr (assoc 340 DimstyleDefinition))) )
(setq DimTxtStyle (cdr (assoc 2 DimTxtEntity)))

 

Edited by Steven P
  • Like 1
Link to comment
Share on other sites

I'm changing my mind, might go dxf code to get the text, create text and match properties as an alternative method

Link to comment
Share on other sites

Hmm...

Not sure, but could you confirm that you can't recomposite DIMENSION entity to static BLOCK and just use NCOPY...

Link to comment
Share on other sites

2 minutes ago, marko_ribar said:

Hmm...

Not sure, but could you confirm that you can't recomposite DIMENSION entity to static BLOCK and just use NCOPY...

 

I would guess... just a guess of course... that if you do that then you loose the dimension functionality - move a line, stretch or whatever and the dimension 'value' won't update with it?

Link to comment
Share on other sites

36 minutes ago, leonucadomi said:

 

image.thumb.png.55758328683f6f84bd9092389afe1889.png

 

 

This is errors before you select a copy to location? Remove BP from getpoint should fix it.

(vla-move copy BP (getpoint BP "\nCopy locaiton"))
to
(vla-move copy BP (getpoint "\nCopy locaiton"))

 

its used to draw a dashed line from the dim you picked like so, but isn't necessary.

 

 

 

  • Like 1
Link to comment
Share on other sites

Try this one, a different way to MHUPP and just for fun

 

Notes:

The font and height used will be as defined in the dimension style and not to any overridden style for that particular dimension entity - I couldn't work out how to do that bit.

There is no error checking or checking that you select a dimension, though that is all online

If I was taking this further I would round the text point coordinates to the nearest 1.25 units, just because (in case snaps and grid and so are turned off)

Need to localise the variables too

 

 

but try this and see if it mostly works

 

 

(defun c:GetDimTxt ( / )
  (defun createtext ( MyText TextPoint font textheight / )
      (entmake (list
      '(0 . "TEXT")
      '(100 . "AcDbEntity")
      '(8 . "0")
      '(100 . "AcDbText")
      (cons 10 TextPoint)
      (cons 40 textheight)
      (cons 1 MyText)
      '(50 . 0.0)
      '(41 . 1.0)
      '(51 . 0.0)
      (cons 7 font)
      '(71 . 0)
      '(72 . 0)
      '(11 0.0 0.0 0.0)
      '(210 0.0 0.0 1.0)
      '(100 . "AcDbText")
      '(73 . 0)
    ));end list, entmake
  )
  (defun FindReplace: (Str$ Find$ Replace$ / Cnt# FindLen# Loop Mid$ NewStr$ ReplaceLen#)
    (setq Loop t Cnt# 1 NewStr$ Str$ FindLen# (strlen Find$) ReplaceLen# (strlen Replace$))
    (while Loop
      (setq Mid$ (substr NewStr$ Cnt# FindLen#))
      (if (= Mid$ Find$)
        (setq NewStr$ (strcat (substr NewStr$ 1 (1- Cnt#)) Replace$ (substr NewStr$ (+ Cnt# FindLen#)))
              Cnt# (+ Cnt# ReplaceLen#)
        );setq
        (setq Cnt# (1+ Cnt#))
      );if
      (if (= Mid$ "") (setq Loop nil))
    );while
    NewStr$
  );defun FindReplace:

  (defun radtodeg( rad / ) (/ (* rad 180.0) pi) )

;;Get Dimensions Stuff
  (setq MyDim (entget (car (entsel "Select Dimension"))))
  (setq DimStyleName (cdr (assoc 3 MyDim)))
  (setq DimstyleDefinition (tblsearch "DIMSTYLE" DimStyleName))
  (setq DimTxtEntity (entget (cdr (assoc 340 DimstyleDefinition))) )
  (setq DimType (cdr (assoc 100 (reverse MyDim))) )
  (setq DimTxtPos (cdr (assoc 11 MyDim)) )
  (setq TextOverride (cdr (assoc 1 MyDim)))
  (setq MyDimValue (cdr (assoc 42 MyDim)))
  (setq DimTxtHeight (cdr (assoc 140 DimstyleDefinition)))
  (setq DimTxtStyle (cdr (assoc 2 DimTxtEntity)))

(setq dimensiontypes (list "AcDbAlignedDimension" "AcDbRotatedDimension" "AcDbOrdinateDimension" "AcDsbAngularDimension"
                           "AcsDb2LineAngularDimension" "AcDb3PointAngularDimension" "AscDbDiametricDimension"
                           "AcDbRadialDimension" "AcDbRadialDimensionLarge" "AcDbArcDimension"
))
  (if (= DimType "AcDb2LineAngularDimension")(setq MyDimValue (radtodeg MyDimValue)))

;;Check text to use
  (if (= TextOverride "")
    (setq MyText (rtos MyDimValue))
    (setq MyText (FindReplace: TextOverride "<>" (rtos MyDimValue)))
  )

  (setq TextPoint (getpoint DimTxtPos "Select Text Point"))
  (createtext MyText TextPoint DimTxtStyle DimTxtHeight)
)

 

 

 

Edited by Steven P
Fixed for Angular Dimensions
  • Like 2
Link to comment
Share on other sites

Likewise I am getting an error - is it a BricsCAD / AutoCAD thing maybe with the line 

    (vla-move copy BP (getpoint "\nCopy locaiton"))

which is where it stops and comes up with the error

"Copy locaiton; error: lisp value has no coercion to VARIANT with this type:"

 

I haven't looked to see why it is doing that though

 

 

Link to comment
Share on other sites

no idea why its working for me and not you guys. took out the vla-copy and just use command

--edit

@leonucadomi you try Steven's lisp?

 

;;----------------------------------------------------------------------------;;
;; Copy dimension value to another location
(defun C:DimCopy (/ dim BP LastEnt  en)
  (vl-load-com)
  (setvar 'cmdecho 0)
  (while (setq dim (car (entsel "\nSelect Dimension: ")))
    (setq obj (vlax-ename->vla-object dim))
    (setq BP (vlax-get obj 'TextPosition))
    (setq LastEnt (entlast))
    (command "_.Copy" dim "" "_non" BP (getpoint BP "\nCopy to: "))
    (command "_Explode" (entlast))
    (if (setq en (entnext LastEnt))
      (while en
        (cond
          ((= "MTEXT" (cdr (assoc 0 (entget en))))
            (command "_Explode" en) ;convert mtext to text
          )
          ((= "TEXT" (cdr (assoc 0 (entget en))))
            (progn)
          )
          (t
            (entdel en)
          )          
        )
        (setq en (entnext en))
      )
    )      
  )
  (setvar 'cmdecho 1)
  (princ)
)

 

Edited by mhupp
  • Like 1
Link to comment
Share on other sites

Here's another way to do it but the end result is MTEXT and you have to pick the text.

(defun c:foo (/ e el p1 p2)
  (if (and (setq e (car (nentsel "\nPick dimension text: ")))
	   (setq p1 (cdr (assoc 10 (setq el (entget e)))))
	   (setq p2 (getpoint p1 "\nSpecify second point: "))
      )
    (entmakex (append (vl-remove-if '(lambda (x) (= 330 (car x))) el) (list (cons 10 p2))))
  )
  (princ)
)

 

2022-07-13_16-31-31.gif

  • Like 3
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...