MULTY LINE DIMENSION TEXT - HELP WITH LISP

[Guest]

Hi I am using this code to add dimension text on multy lines . This code works fine in simple rectangles or with linew olmost vertical. When i thy to use it to lines with another angle didnt work. I  upload the code and a sample.dwg

 

(vl-load-com)

(defun C:LineDimAnnot ; = Length at Mid-Point
  (/ *error* LineDimAnnot-reset LineDimAnnotss doc svnames svvals n path pathdata pathtype pathextr ucschanged LineDimAnnot-pt len)
  (command "_.-layer" "_make" "_DIAST" "_color" 93 "" "_lweight" 0.30 "" "")
  (command "_.-style" "_Diast" "wgsimpl.shx" "_annotative" "_yes" "_no" 1.75 1.0 0.0 "_no" "_no" "_no")
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    ); if
    (if ucschanged (command "_.ucs" "_prev"))
      ;; ^ don't go back unless routine reached UCS change but didn't change it back
    (vla-endundomark doc)
    (LineDimAnnot-reset)
  ); defun - *error*

  (defun LineDimAnnot-reset ()
    (mapcar 'setvar svnames svvals); reset
    (princ)
  ); defun - LineDimAnnot-reset

  (prompt "\nTo mark Length(s) at object Midpoint(s),")
  (if
    (setq LineDimAnnotss (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))))
    (progn ; then
      (vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
      (setq
        svnames '(osmode blipmode cmdecho)
        svvals (mapcar 'getvar svnames)
      ); setq
      (setvar 'cmdecho 0)
      (repeat (setq n (sslength LineDimAnnotss))
        (setq
          path (ssname LineDimAnnotss (setq n (1- n)))
          pathdata (entget path)
          pathtype (cdr (assoc 0 pathdata))
          pathtype
            (if (wcmatch pathtype "POLYLINE")
              (strcase (substr (cdr (assoc 100 (reverse pathdata))) 5)); then
                ;; ^ = entity type from second (assoc 100) without "AcDb" prefix;  uses this because (assoc 0)
                ;; value is the same for 2D heavy & 3D Polylines; can set UCS to match former, but not latter
              pathtype ; else - leave alone
            ); if and pathtype
          pathextr (cdr (assoc 210 pathdata))
        ); setq
        (if ; set UCS to match object only under certain circumstances
          (or ; look at entity types other than 3D Polylines and 3D Splines
            (and
              (= pathtype "LINE")
              (not ; unequal Z components at ends, in current CS
                (equal
                  (caddr (trans (cdr (assoc 10 pathdata)) 0 1))
                  (caddr (trans (cdr (assoc 11 pathdata)) 0 1))
                  1e-12
                ); equal
              ); not
            ); and - Line UCS check
            (and
              (wcmatch pathtype "ARC,CIRCLE,ELLIPSE,LWPOLYLINE,2DPOLYLINE")
              (not (equal (trans pathextr 0 1) '(0 0 1) 1e-6)); extrusion direction not = current CS
            ); and - A/C/E/LWP/2dP UCS check
            (and
              (= pathtype "SPLINE")
              (if pathextr (not (equal (trans pathextr 0 1) '(0 0 1) 1e-12)))
                ;; ^ planar [2D] Splines have 210 value; non-planar [3D] do not
            ); and - Spline UCS check
          ); or - need to change UCS
          (progn
            (if (equal pathextr '(0 0 1) 1e-12)
              (command "_.ucs" "_world"); then
              (if (= pathtype "LINE") ; outer else -- set UCS to match object
                (command "_.ucs" (vlax-curve-getStartPoint path) (vlax-curve-getEndPoint path) "")
                  ; then -- sometimes UCS OB on Line does it with Line up Z axis
                (command "_.ucs" "_new" "_object" path); else [other entity types]
              ); if
            ); if
            (setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't get to it
          ); progn
        ); if - UCS match object
        (mapcar 'setvar svnames '(0 0)); Osnap and blips off
        (command
          "_.text" "_justify" "_bc"
          (trans
            (setq LineDimAnnot-pt ; insertion point
              (vlax-curve-getPointAtDist ; midway along length
                path
                (/
                (setq len (vlax-curve-getDistAtParam path (vlax-curve-getEndParam path))); overall length
                  2
                ); /
              ); getPointAtDist
            ); setq
            0 1 ; WCS to current CS
          )
        ); command ; leave in Text command
        (if (member '(40 . 0.0) (entget (tblobjname "style" (getvar 'textstyle)))) (command ""))
          ; accept current-height default if non-fixed-height or non-annotative Style
        (command ; continue
          (angtos ; rotation -- local direction of path
            (+
              (angle
                '(0 0 0)
                (trans
                  (vlax-curve-getFirstDeriv
                    path
                    (vlax-curve-getParamAtPoint path LineDimAnnot-pt)
                  ); getFirstDeriv
                  0 1 T; WCS to current CS, as displacement
                ); trans
              ); angle
              (if ; put text on outboard side of Arc/Circle/Ellipse/LWPline arc segment
                (or
                  (wcmatch pathtype "ARC,CIRCLE,ELLIPSE")
                  (and
                    (= pathtype "LWPOLYLINE") ;;;;; what about "heavy" Polyline arc segment?
                    (> ; midway point on arc segment with CCW curvature?
                      (vla-getBulge (vlax-ename->vla-object path) (vlax-curve-getParamAtPoint path LineDimAnnot-pt))
                      0.0
                    ); >
                  ); and
                ); or
                pi 0 ; then = spin around, else = direction unaltered
              ); if
            ); +
            (getvar 'aunits) 8
          ); angtos
          (rtos len 2 2); text content
        ); command
        (if ucschanged (progn (command "_.ucs" "_prev") (setq ucschanged nil)))
          ; eliminate UCS reset in *error* since routine did it already
      ); repeat
      (LineDimAnnot-reset)
      (vla-endundomark doc)
    ); progn
  ); if
;Αλλαγη layer στο 0
(mapcar 'setvar '(clayer cecolor celtype celweight) (list "0" "BYLAYER" "BYLAYER" -1))
); defun - LineDimAnnot

 

 

Thanks

 

sample.dwg

Edited December 5, 2019 by prodromosm

[Guest]

Any ideas ?

[BIGAL]

Throw away and start again, using co-ords would be much easier, as it gives angle of text, do a readable angle text and then place text. This is straights only comment.

 

Just search for label plines should be one out there. Have a look at Lee-mac.com.

[Guest]

 can any one fix it?

Edited December 6, 2019 by prodromosm

[Guest]

i fnd this code. I think it works. I have add the text style, layers , annotation text

 

;------------------------------------------------ LenghtOfObject --------------
(defun LenghtOfObject (obj / len)
(if (vl-catch-all-error-p (setq len (vl-catch-all-apply 'vlax-curve-getDistAtParam
(list obj (vl-catch-all-apply 'vlax-curve-getEndParam (list obj)))))) nil len
)
)
;------------------------------------------------ c:LengthText ----------------
(defun c:LengthText ( / *ModelSpace* sel)
(vl-load-com)
(setq *ModelSpace* (vla-get-ModelSpace (vla-get-ActiveDocument(vlax-get-acad-object))))
(setvar "errno" 0) ; when the user on ssget press Enter the errno is set to 52
(while (and (setq sel (ssget))(/= (getvar "errno") 52))
(if sel
(progn
(mapcar (function (lambda (ent / obj olg stpt endpt next_pt midpt TxtObj midpt1)
(setq Obj (vlax-ename->vla-object ent))
(if (and (setq olg (LenghtOfObject obj))(> olg 0))
(progn
(setq stpt (vlax-curve-getStartPoint obj))
(setq endpt (vlax-curve-getendpoint obj))
(setq midPt (vlax-curve-getPointAtDist obj (* olg 0.5)))
(setq midPt1 (polar midPt (+ (* 0.5 pi)(angle stpt endpt)) 1e-3))
(setq TxtObj (vla-addText *ModelSpace* (rtos olg 2 2) (vlax-3d-point midpt) (getvar"textsize"))) ;_ end of vla-addText
(vla-put-Rotation TxtObj (+ (* 1.5 pi)(angle (vlax-curve-getClosestPointTo obj midpt1) midpt1)))
(setq midpt (vla-get-InsertionPoint TxtObj))
(vla-put-alignment TxtObj acAlignmentBottomCenter)
(vla-put-TextAlignmentPoint TxtObj midpt)
)
(if (ssmemb ent sel)(ssdel ent sel))
)
))(vl-remove-if-not '(lambda(x)(= (type x) 'ENAME)) (mapcar 'cadr (ssnamex sel))))
)
)
)
(princ)
)

 

[Guest]

Hi i need some help with the text size

 

I need in 1:200m  scale to have  Model text  size 0.35 , and  Paper text size 1.75

 

I uplode a test.dwg with the annotation scales (for test)

 

;------------------------------------------------ LenghtOfObject --------------
(defun LenghtOfObject (obj / len)
(if (vl-catch-all-error-p (setq len (vl-catch-all-apply 'vlax-curve-getDistAtParam
(list obj (vl-catch-all-apply 'vlax-curve-getEndParam (list obj)))))) nil len
)
)
;------------------------------------------------ c:LengthText ----------------
(defun c:LengthText ( / *ModelSpace* sel)
  (command "_.-layer" "_make" "_DIAST" "_color" 93 "" "_lweight" 0.30 "" "")
  (command "_.-style" "_Diast" "wgsimpl.shx" "_annotative" "_yes" "_no" 1.75 1.0 0.0 "_no" "_no" "_no")
(vl-load-com)
(setq *ModelSpace* (vla-get-ModelSpace (vla-get-ActiveDocument(vlax-get-acad-object))))
(setvar "errno" 0) ; when the user on ssget press Enter the errno is set to 52
(while (and (setq sel (ssget))(/= (getvar "errno") 52))
(if sel
(progn
(mapcar (function (lambda (ent / obj olg stpt endpt next_pt midpt TxtObj midpt1)
(setq Obj (vlax-ename->vla-object ent))
(if (and (setq olg (LenghtOfObject obj))(> olg 0))
(progn
(setq stpt (vlax-curve-getStartPoint obj))
(setq endpt (vlax-curve-getendpoint obj))
(setq midPt (vlax-curve-getPointAtDist obj (* olg 0.5)))
(setq midPt1 (polar midPt (+ (* 0.5 pi)(angle stpt endpt)) 1e-3))
(setq TxtObj (vla-addText *ModelSpace* (rtos olg 2 2) (vlax-3d-point midpt) (getvar"textsize"))) ;_ end of vla-addText
(vla-put-Rotation TxtObj (+ (* 1.5 pi)(angle (vlax-curve-getClosestPointTo obj midpt1) midpt1)))
(setq midpt (vla-get-InsertionPoint TxtObj))
(vla-put-alignment TxtObj acAlignmentBottomCenter)
(vla-put-TextAlignmentPoint TxtObj midpt)
)
(if (ssmemb ent sel)(ssdel ent sel))
)
))(vl-remove-if-not '(lambda(x)(= (type x) 'ENAME)) (mapcar 'cadr (ssnamex sel))))
)
)
)
;change layer to 0
(mapcar 'setvar '(clayer cecolor celtype celweight) (list "0" "BYLAYER" "BYLAYER" -1))
(princ)
)

 

 

Thanks

test.dwg

[Guest]

can any one help me with the text size ?

 

Thanks

[Guest]

I think thaat the problem with the text height  is here

 

(setq TxtObj (vla-addText *ModelSpace* (rtos olg 2 2) (vlax-3d-point midpt) (getvar"textsize"))) ;_ end of vla-addText

but  i don't know how to fix it. Can any one help ?

 

Thanks

[Guest]

I want in any scale Paper text height = 1.75  and in scale 1:200 Model text  size 0.35 . I can any one help?

 

Thanks

[hanhphuc]

15 hours ago, prodromosm said:

I want in any scale Paper text height = 1.75  and in scale 1:200 Model text  size 0.35 . I can any one help?

 

Thanks

 

 

Annotation scale?

( * (getvar"textsize") scale )

 

p/s: v2007 no such anno scale ability, we received newer dwg became massy if converted&opened in ac2007 which different sizes of annotated texts overlapped!!

[Guest]

1) I try this but is not working properly.

2) the second problem is that after  the lelection of the lines write the text but the lisp don't stop. the cersor  is rectangle .

3) The curent layer not ) but _Diast because the code is still running

(setq TxtObj (vla-addText *ModelSpace* (rtos olg 2 2) (vlax-3d-point midpt) (* (getvar"textsize") 0.2)))

Some times work- some times not working

Edited December 8, 2019 by prodromosm