Help with multy area lisp

[Guest]

Hi am using this code to calculate and insert area text in multyple polygons. I have a problem with the annotation text size.

1) I want in paper space the text size 2.5 and in model space if tor example the  annotation scale set to 1:200 the size of the text be 0.5.

2) I want the insert text justify center

Can any one help ?

 

;;; Calculate area of closed polyline and place text in Sq.m in center of closed area
;;; Modified by Igal Aberbuh 2016
(defun C:at (/ acsp adoc ar axss hgt maxp minp obj p1 p2 pc ss txt)
(COMMAND "_layer" "_m" "_Area" "_c" "41""" "")
(command "_.-style" "_Multy Area" "arial.ttf" "_annotative" "_yes" "_no" 2.5 1.0 0.0 "_no" "_no" "_no")
(vl-load-com)
(setq adoc (vla-get-activedocument
(vlax-get-acad-object)
)
)
(if (and
(= (getvar "tilemode") 0)
(= (getvar "cvport") 1)
)
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-startundomark (vla-get-activedocument
(vlax-get-acad-object)))
(initget 7)

(setq textsize 1)
;(setvar 'textsize
;(cond ((getdist (strcat "\nSpecify Area text height by two points on screen : ")))
;((getvar 'textsize))
;)
;)

(prompt "\nSelect objects on screen to add area label")
(if (setq ss (ssget))
(progn

(setq axss (vla-get-activeselectionset adoc))
(vlax-for obj axss
(if (not
(vl-catch-all-error-p
(setq
ar (vl-catch-all-apply
(function (lambda()
(vlax-curve-getarea obj)))))))
(progn
(setq txt (strcat "Area = " (rtos ar 2 2)"m²"))
(vla-getboundingbox obj 'minp 'maxp)
(setq p1 (vlax-safearray->list minp)
p2 (vlax-safearray->list maxp)

pc (mapcar (function (lambda(a b)(/ (+ a b) 2))) p1 p2)

)
(vlax-invoke acsp 'Addtext txt pc (getvar 'textsize))
)
)
)
)
)
(vla-endundomark (vla-get-activedocument
(vlax-get-acad-object)))
;change layer to 0
(mapcar 'setvar '(clayer cecolor celtype celweight) (list "0" "BYLAYER" "BYLAYER" -1))
(princ)
)

Thanks

[Guest]

Any ideas?

[devitg]

Please upload your-real-sample.dwg with such sample , as in in Model as in Paper

[Guest]

hi devitg here is a sample

test.dwg

[BIGAL]

A couple of suggestions

 

(setq ss (ssget)) add a filter to select only "LWPOLYLINE"

 

Set your text style to one which is annotative (getvar 'textstyle) check if what you want

 

Some one will correct me but not sure if using VL can add "center" rather have to amend the text object after creation. If use (command yes "c" is an option.

 

;not tested
(setq obj (vlax-invoke acsp 'Addtext txt pc (getvar 'textsize)))
(vla-put-alignment obj 1)

 

[Guest]

Hi BiGAL. I cant figure it out. The problem is in  text size and

 

Quote

(setq ss (ssget)) add a filter to select only "LWPOLYLINE"

 

Edited November 29, 2019 by prodromosm

[Guest]

I add the filter to select polylines and automatic insert the Area text. Now i need help with the text size and the justification center

;;; Calculate area of closed polyline and place text in Sq.m in center of closed area
;;; Modified by Igal Aberbuh 2016
(defun C:at (/ acsp adoc ar axss hgt maxp minp obj p1 p2 pc ss txt)
(COMMAND "_layer" "_m" "_Area" "_c" "41""" "")
(command "_.-style" "_Multy Area" "arial.ttf" "_annotative" "_yes" "_no" 2.5 1.0 0.0 "_no" "_no" "_no")
(vl-load-com)
(setq adoc (vla-get-activedocument
(vlax-get-acad-object)
)
)
(if (and
(= (getvar "tilemode") 0)
(= (getvar "cvport") 1)
)
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-startundomark (vla-get-activedocument
(vlax-get-acad-object)))
(initget 7)

(setq textsize 1)
;(setvar 'textsize
;(cond ((getdist (strcat "\nSpecify Area text height by two points on screen : ")))
;((getvar 'textsize))
;)
;)

(prompt "\nSelect objects on screen to add area label")
(if (setq ss (ssget "X" (list (cons 0 "*POLYLINE"))))
(progn

(setq axss (vla-get-activeselectionset adoc))
(vlax-for obj axss
(if (not
(vl-catch-all-error-p
(setq
ar (vl-catch-all-apply
(function (lambda()
(vlax-curve-getarea obj)))))))
(progn
(setq txt (strcat "Area = " (rtos ar 2 2)"m²"))
(vla-getboundingbox obj 'minp 'maxp)
(setq p1 (vlax-safearray->list minp)
p2 (vlax-safearray->list maxp)

pc (mapcar (function (lambda(a b)(/ (+ a b) 2))) p1 p2)

)
(vlax-invoke acsp 'Addtext txt pc (getvar 'textsize))
)
)
)
)
)
(vla-endundomark (vla-get-activedocument
(vlax-get-acad-object)))
;change layer to 0
(mapcar 'setvar '(clayer cecolor celtype celweight) (list "0" "BYLAYER" "BYLAYER" -1))
(princ)
)

Thanks

[dlanorh]

Try the attached. I've adapted one of my older routines to work as required, but it inserts MText not text.

PolyArea.LSP

[Guest]

Thank you dlanorh

[BIGAL]

I posted the answer for "center" (vla-put-alignment obj x) the x changes the alignment I would have to figure out the "Center" value.

[Guest]

Thanks BIGAL

[Guest]

Hi. I know that this post is old, but I try to change the annotation text to simple text and the routine is not working well. Insert the area only one polygon not to all

 

;; MostInnerPoint by Gilles Chanteau (_gile)
(defun MostInnerPoint (obj fuzz / 2d-coord->pt-lst 3d-coord->pt-lst dich-sub len tmp)

  (defun 2d-coord->pt-lst (lst)
    (if lst (cons (list (car lst) (cadr lst)) (2d-coord->pt-lst (cddr lst))))
  );end_defun

  (defun 3d-coord->pt-lst (lst)
    (if lst (cons (list (car lst) (cadr lst) (caddr lst)) (3d-coord->pt-lst (cdddr lst))))
  );end_defun

  (defun dich-sub (inf sup / of new pts)
    (if (equal inf sup fuzz)
      (progn
        (setq of  (vlax-invoke obj 'Offset inf)
              pts (if (= (vla-get-ObjectName (car of)) "AcDbPolyline")
                    (2d-coord->pt-lst (vlax-get (car of) 'Coordinates))
                    (3d-coord->pt-lst (vlax-get (car of) 'ControlPoints))
                  );end_if
        );end_setq
        (mapcar 'vla-delete of)
        (mapcar (function (lambda (x) (/ x (length pts)))) (apply 'mapcar (cons '+ pts)))
      );end_progn
      (progn
        (setq new (/ (+ inf sup) 2.0)
              of  (vl-catch-all-apply 'vlax-invoke (list obj 'Offset new))
        );end_setq
        (if (vl-catch-all-error-p of)
          (dich-sub inf new)
          (progn
            (mapcar 'vla-delete of)
            (dich-sub new sup)
          )
        );end_if
      );end_progn
    );end_if
  );end_defun

  (if (and  (member (vla-get-ObjectName obj) '("AcDbPolyline" "AcDbSpline"))
            (vlax-curve-isClosed obj)
            (or (= (vla-get-ObjectName obj) "AcDbPolyline")
                (vlax-curve-isPlanar obj)
            );end_or
            (setq tmp (vl-catch-all-apply 'vlax-invoke (list obj 'Offset fuzz)))
            (setq len (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj))
                  tmp (car tmp)
            );end_setq
            (if (< len (vlax-curve-getDistAtParam tmp (vlax-curve-getEndParam tmp)))
              (setq len (/ len (* -2 pi)))
              (setq len (/ len (* 2 pi)))
            );end_if
            (not (vla-delete tmp))
      );end_and
      (dich-sub 0.0 len)
  );end_if
);end_defun (MostInnerPoint)

(vl-load-com)

;Polyline Area Field
(defun c:PAM2 (/ *error* sv_lst sv_vals c_doc ms a_u tht ss ent obj p_lst mi_pt fld n_obj)

  (defun *error* ( msg )
    (mapcar 'setvar sv_lst sv_vals)
    (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
    (princ)
  );end_*error*_defun
 ;(setq scl (getvar "useri1"))
 (setq scl (getint "\n Set scale  (50,100,200,250,500,etc) :"))
  (setq sv_lst (list 'osmode 'cmdecho)
        sv_vals (mapcar 'getvar sv_lst)
        c_doc (vla-get-activedocument (vlax-get-acad-object))
        ms (vla-get-modelspace c_doc)
        c_lyrs (vla-get-layers c_doc)
        a_u (getvar 'insunits)
        tht (* 0.003 scl)
  );end_setq

  (mapcar 'setvar sv_lst '(0 0))

  (cond ( (not (tblsearch "layer" "_Area")) (vlax-put-property (vla-add c_lyrs "_Area") 'color 41)))

  (cond ( (not (tblsearch "style" "_Multy Area")) (command "-style" "Multy Area" "arial.ttf" "0" "1" "0" "N" "N" "N")))

:================================================================================
; Can any one delete the extra lines. I want to work only for sq.m ..... Thanks
;==================================================================================

  (cond ( (not (vl-position a_u '(1 2 4 6))) (setq a_u (getstring "\nEnter drawing area units : ")))
        ( (= a_u 1) (setq a_u (strcat "in" (chr 178))))
        ( (= a_u 2) (setq a_u (strcat "ft" (chr 178))))
        ( (= a_u 4) (setq a_u (strcat "mm" (chr 178))))
        ;( (= a_u 6) (setq a_u (strcat "m" (chr 178))))
        ( (= a_u 6) (setq a_u (strcat "sq.m")))
  );end_cond

  (setq ss (ssget (list '(0 . "*POLYLINE") '(410 . "Model"))))

  (cond (ss
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
          (vla-startundomark c_doc)

          (repeat (setq cnt (sslength ss))
            (setq obj (vlax-ename->vla-object (setq ent (ssname ss (setq cnt (1- cnt)))))
                  p_lst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget ent)))
            );end_setq

            (cond ( (and (equal (car p_lst) (last p_lst) 0.0001) (= :vlax-false (vlax-get-property obj 'closed)))
                    (setq p_lst (reverse (cdr (reverse p_lst))))
                    (vlax-put obj 'coordinates (apply 'append p_lst))
                    (vlax-put-property obj 'closed :vlax-true)
                  )
            );end_cond

            (cond ( (vlax-property-available-p obj 'area)
                    (setq mi_pt (MostInnerPoint obj 0.001)
                         ; fld (strcat "Area : " (rtos (vlax-get-property obj 'area) 2 3) " " a_u)
                          fld (strcat "Ε = " (rtos (vlax-get-property obj 'area) 2 2) " " a_u)
                          n_obj (vla-addmtext ms (vlax-3d-point mi_pt) 0 fld)
                    );end_setq
                    (mapcar '(lambda (x y) (vlax-put-property n_obj x y))
                      (list 'attachmentpoint 'insertionpoint 'height 'layer 'stylename)
                      (list acAttachmentPointMiddleCenter (vlax-3d-point mi_pt) tht "Area" "Multy Area")
                    );end_mapcar
                  )
            );end_cond
          );end_repeat
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
        )
  );end_cond

  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun

 

 

Thanks

[Guest]

I think i fix it .Thanks