Jump to content

Help with multy area lisp

Guest

By Guest
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Guest

Guest

Posted
Posted

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

devitg Experienced

devitg

Posted
Posted

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

  • Like 1
BIGAL Grand Master

BIGAL

Posted
Posted

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

Guest

Posted
Posted (edited)

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 by prodromosm
Guest

Guest

Posted
Posted

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 Mentor

dlanorh

Posted
Posted

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

PolyArea.LSP

BIGAL Grand Master

BIGAL

Posted
Posted

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.

  • 2 years later...
Guest

Guest

Posted
Posted

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

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.

×
 Share
Go to topic listing
×
×
  • Create New...