« previous next »
Pages: [1] |   Go Down

Author Topic: Analytic Calculation of area - Help to updatethe code  (Read 928 times)

0 Members and 1 Guest are viewing this topic.

mhy3sx

  • Newt
  • Posts: 120
Analytic Calculation of area - Help to updatethe code
« on: March 23, 2023, 05:36:21 PM »
Hi. I am using this code to analytic calculate multi areas. The code work fine, but I want to do a simple update, but I am stuck. This code add in each polygon  numbers  as E1,E2....En . I want to change that and ask me for the letter. for example If a have 5 group of polygons the first group will be A1,A2,...An  the second B1,B2..Bn etc. This will be done if I have the option to give the letter , not to be all the times E.

Code - Auto/Visual Lisp: [Select]
  1.  (defun c:areacal ( / AcDoc Space nw_style js nb ent dxf_ent ptlst n old_textsize count app_txt surf cum_area nb pt_ins val_txt lst_bis l_4d max_d pos pt1 pt2 pt3 d1 d2 h t_spc nw_obj ent_text key)
  2.     (setq scl (getvar "useri1"))
  3.      (setq ht (* 0.003 scl))
  5.         (vla-startundomark AcDoc)
  6.         (vla-put-ActiveSpace AcDoc acModelSpace)
  7.         (cond
  8.                 ((null (tblsearch "LAYER" "AREA CALC"))
  9.                         (vlax-put (vla-add (vla-get-layers AcDoc) "AREA CALC") 'color 7)
  10.                 )
  11.         )
  12.         (cond
  13.                 ((null (tblsearch "STYLE" "AREA CALC"))
  14.                         (setq nw_style (vla-add (vla-get-textstyles AcDoc) "AREA CALC"))
  15.                         (mapcar
  16.                                 '(lambda (pr val)
  17.                                         (vlax-put nw_style pr val)
  18.                                 )
  19.                                 (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
  20.                                 (list (strcat (getenv "windir") "\\fonts\\arial.ttf") 0.0 0.0 1.0 0.0)
  21.                         )
  22.                 )
  23.         )
  24.         (while (null (setq js (ssget '((0 . "LWPOLYLINE") (-4 . "<AND") (-4 . "&") (70 . 1) (-4 . ">") (90 . 2) (-4 . "<") (90 . 5) (-4 . "AND>"))))))
  25.         (repeat (setq nb (sslength js))
  26.                 (setq
  27.                         ent (ssname js (setq nb (1- nb)))
  28.                         dxf_ent (entget ent)
  29.                         ptlst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxf_ent))
  30.                         n (length ptlst)
  31.                 )
  32.                 (if (eq n 4)
  33.                         (if
  34.                                 (and
  35.                                         (not (equal (rem (angle (car ptlst) (cadr ptlst)) pi) (rem (angle (caddr ptlst) (cadddr ptlst)) pi) 1E-08))
  36.                                         (not (equal (rem (angle (cadr ptlst) (caddr ptlst)) pi) (rem (angle (cadddr ptlst) (car ptlst)) pi) 1E-08))
  37.                                 )
  38.                                 (ssdel ent js)
  39.                         )
  40.                 )
  41.         )
  42.         (cond
  43.                 ((and js (> (sslength js) 0))
  44.                         (sssetfirst nil js)
  45.                         (initget "Yes No")
  46.                         (cond
  47.                                 ((not (eq (getkword "\n Insert calculations [Yes/No]? <Yes>: ") "No"))
  48.                                         (sssetfirst nil nil)
  49.                                         (setq
  50.                                                 old_textsize (getvar "TEXTSIZE")
  51.                                                 count 0
  52.                                                 app_txt ""
  53.                                                 cum_area 0.0
  54.                                         )
  55.                                         (setvar "TEXTSIZE" 2.5)
  56.                                         (repeat (setq nb (sslength js))
  57.                                                 (setq
  58.                                                         ent (ssname js (setq nb (1- nb)))
  59.                                                         dxf_ent (entget ent)
  60.                                                         ptlst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxf_ent))
  61.                                                         n (length ptlst)
  62.                                                         pt_ins (list (/ (apply '+ (mapcar 'car ptlst)) n) (/ (apply '+ (mapcar 'cadr ptlst)) n))
  63.                                                         val_txt
  64.                                                         (if (eq n 3)
  65.                                                                 (progn
  66.                                                                         (setq
  67.                                                                                 lst_bis (append (cdr ptlst) (list (car ptlst)))
  68.                                                                                 l_4d (mapcar 'distance ptlst lst_bis)
  69.                                                                                 max_d (apply 'max l_4d)
  70.                                                                                 pos (vl-position max_d l_4d)
  71.                                                                                 pt1 (nth pos ptlst)
  72.                                                                                 pt2 (nth pos lst_bis)
  73.                                                                                 pt3 (car (vl-remove pt2 (vl-remove pt1 ptlst)))
  74.                                                                                 d1
  75.                                                                                 (distance
  76.                                                                                         pt3
  77.                                                                                         (inters
  78.                                                                                                 pt1
  79.                                                                                                 pt2
  80.                                                                                                 pt3
  81.                                                                                                 (polar pt3 (+ (angle pt1 pt2) (* pi 0.5)) (distance pt1 pt2))
  82.                                                                                                 nil
  83.                                                                                         )
  84.                                                                                 )
  85.                                                                                 surf (* (atof(rtos max_d 2 2)) (atof (rtos d1 2 2)) 0.5)
  86.                                                                                 cum_area (atof (rtos (+ surf cum_area) 2 3))
  87.                                                                         )
  88.                                                                         (strcat
  89.                                                                                 "E" (itoa (setq count (1+ count))) " = "
  90.                                                                                 "1/2 x "
  91.                                                                                 (rtos max_d 2 2)
  92.                                                                                 " x "
  93.                                                                                 (rtos d1 2 2)
  94.                                                                                 " = "
  95.                                                                                 (rtos surf 2 2) " sqm\\P"
  96.                                                                         )
  97.                                                                 )
  98.                                                                 (if
  99.                                                                         (and
  100.                                                                                 (equal (abs (- (rem (angle (car ptlst) (cadr ptlst)) pi) (rem (angle (car ptlst) (cadddr ptlst)) pi))) (* 0.5 pi) 1E-08)
  101.                                                                                 (equal (abs (- (rem (angle (cadr ptlst) (caddr ptlst)) pi) (rem (angle (caddr ptlst) (cadddr ptlst)) pi))) (* 0.5 pi) 1E-08)
  102.                                                                         )
  103.                                                                         (progn
  104.                                                                                 (setq
  105.                                                                                         d1 (atof (rtos (distance (car ptlst) (cadr ptlst)) 2 2))
  106.                                                                                         d2 (atof (rtos (distance (cadr ptlst) (caddr ptlst)) 2 2))
  107.                                                                                         surf (atof (rtos (* d1 d2) 2 2))
  108.                                                                                         cum_area (atof (rtos (+ surf cum_area) 2 2))
  109.                                                                                 )
  110.                                                                                 (strcat
  111.                                                                                         "E" (itoa (setq count (1+ count))) " = "
  112.                                                                                         (rtos d1 2 2)
  113.                                                                                         " x "
  114.                                                                                         (rtos d2 2 2)
  115.                                                                                         " = "
  116.                                                                                         (rtos surf 2 2)
  117.                                                                                         " sqm\\P"
  118.                                                                                 )
  119.                                                                         )
  120.                                                                         (progn
  121.                                                                                 (if (equal (rem (angle (car ptlst) (cadr ptlst)) pi) (rem (angle (caddr ptlst) (cadddr ptlst)) pi) 1E-08)
  122.                                                                                         (setq
  123.                                                                                                 d1 (atof (rtos (distance (car ptlst) (cadr ptlst)) 2 2))
  124.                                                                                                 d2 (atof (rtos (distance (caddr ptlst) (cadddr ptlst)) 2 2))
  125.                                                                                                 h (atof (rtos (distance (car ptlst) (inters (car ptlst) (polar (car ptlst) (+ (angle (car ptlst) (cadr ptlst)) (* 0.5 pi)) 1.0) (caddr ptlst) (cadddr ptlst) nil)) 2 2))
  126.                                                                                         )
  127.                                                                                         (setq
  128.                                                                                                 d1 (atof (rtos (distance (cadr ptlst) (caddr ptlst)) 2 2))
  129.                                                                                                 d2 (atof (rtos (distance (car ptlst) (cadddr ptlst)) 2 2))
  130.                                                                                                 h (atof (rtos (distance (cadr ptlst) (inters (cadr ptlst) (polar (cadr ptlst) (+ (angle (cadr ptlst) (caddr ptlst)) (* 0.5 pi)) 1.0) (car ptlst) (cadddr ptlst) nil)) 2 2))
  131.                                                                                         )
  132.                                                                                 )
  133.                                                                                 (setq
  134.                                                                                         surf (atof (rtos (* (+ d1 d2) h 0.5) 2 2))
  135.                                                                                         cum_area (atof (rtos (+ surf cum_area) 2 2))
  136.                                                                                 )
  137.                                                                                 (strcat
  138.                                                                                         "E" (itoa (setq count (1+ count))) " =  1/2 x ("
  139.                                                                                         (rtos d1 2 2)
  140.                                                                                         " + "
  141.                                                                                         (rtos d2 2 2)
  142.                                                                                         ") x "
  143.                                                                                         (rtos h 2 2)
  144.                                                                                         " = "
  145.                                                                                         (rtos surf 2 2)
  146.                                                                                         " sqm\\P"
  147.                                                                                 )
  148.                                                                         )
  149.                                                                 )
  150.                                                         )
  151.                                                         app_txt (strcat app_txt val_txt)
  152.                                                 )
  153.                                                 (entmake
  154.                                                         (list
  155.                                                                 '(0 . "TEXT")
  156.                                                                 '(100 . "AcDbEntity")
  157.                                                                 (cons 8 "AREA CALC")
  158.                                                                 '(100 . "AcDbText")
  159.                                                                 (cons 10 pt_ins)
  160.                                                                 ;(cons 40 (getvar "TEXTSIZE"))
  161.                                                                 (cons 40 ht)
  162.                                                                 (cons 1 (strcat "E" (itoa count)))
  163.                                                                 (cons 50 (angle '(0 0 0) (getvar "UCSXDIR")))
  164.                                                                 '(41 . 1.0)
  165.                                                                 '(51 . 0.0)
  166.                                                                 (cons 7 "Layout")
  167.                                                                 '(71 . 0)
  168.                                                                 '(72 . 1)
  169.                                                                 (cons 11 pt_ins)
  170.                                                                 (assoc 210 dxf_ent)
  171.                                                                 '(100 . "AcDbText")
  172.                                                                 '(73 . 2)
  173.                                                         )
  174.                                                 )
  175.                                         )
  176.                                         (initget "Modelspace Paperspace")
  177.                                         (setq t_spc (getkword "\n Insert calculations [Modelspace/Paperspace]? <Modelspace>: "))
  178.                                         (cond
  179.                                                 ((eq t_spc "Paperspace")
  180.                                                         (vla-put-ActiveSpace AcDoc acPaperSpace)
  181.                                                         (vla-put-MSpace AcDoc :vlax-false)
  182.                                                         (setq Space (vla-get-PaperSpace AcDoc))
  183.                                                 )
  184.                                                 (T
  185.                                                         (vla-put-ActiveSpace AcDoc acModelSpace)
  186.                                                         (if (not (eq (getvar "TILEMODE") 1)) (vla-put-MSpace AcDoc :vlax-true))
  187.                                                         (setq Space (vla-get-ModelSpace AcDoc))
  188.                                                 )
  189.                                         )
  190.                                         (setq nw_obj
  191.                                                 (vla-addMtext Space
  192.                                                         (vlax-3d-point (trans (getvar "VIEWCTR") 1 0))
  193.                                                         0.0
  194.                                                         (strcat app_txt "Eall = " (rtos cum_area 2 2) " sqm")
  195.                                                 )
  196.                                         )
  197.                                         (mapcar
  198.                                                 '(lambda (pr val)
  199.                                                         (vlax-put nw_obj pr val)
  200.                                                 )
  201.                                                 (list 'AttachmentPoint 'Height 'DrawingDirection 'StyleName 'Layer 'Rotation 'BackgroundFill 'Color)
  202.                                                 (list 1 (getvar "TEXTSIZE") 5 "Layout" "Layout" 0.0 0 0)
  203.                                         )
  204.                                         (setq
  205.                                                 ent_text (entlast)
  206.                                                 dxf_ent (entget ent_text)
  207.                                                 dxf_ent (subst (cons 90 1) (assoc 90 dxf_ent) dxf_ent)
  208.                                                 dxf_ent (subst (cons 63 255) (assoc 63 dxf_ent) dxf_ent)
  209.                                         )
  210.                                         (entmod dxf_ent)
  211.                                         (while (and (setq key (grread T 4 0)) (/= (car key) 3))
  212.                                                 (cond
  213.                                                         ((eq (car key) 5)
  214.                                                                 (setq dxf_ent (subst (cons 10 (trans (cadr key) 1 0)) (assoc 10 dxf_ent) dxf_ent))
  215.                                                                 (entmod dxf_ent)
  216.                                                         )
  217.                                                 )
  218.                                         )
  219.                                         (setvar "TEXTSIZE" old_textsize)
  220.                                 )
  221.                                 (T (sssetfirst nil nil) (princ "\nFunction canceled"))
  222.                         )
  223.                 )
  224.                 (T (princ "\nSelected items are invalid"))
  225.         )
  226.         (vla-endundomark AcDoc)
  227.         (prin1)
  228. ;layer 0
  229. (mapcar 'setvar '("clayer" "cecolor" "celtype" "celweight") (list "0" "BYLAYER" "BYLAYER" -1))
  230. (*error* "")
  231.     )
  232.  
  233.  

Any options ?

Thanks














« Last Edit: March 23, 2023, 05:42:29 PM by mhy3sx »
Logged

BIGAL

  • Swamp Rat
  • Posts: 1411
  • 40 + years of using Autocad
Re: Analytic Calculation of area - Help to updatethe code
« Reply #1 on: March 23, 2023, 08:08:39 PM »
1st comment (setq scl (getvar "useri1")), the useri1 can be overridden by other software have a look at LDATA.

Code: [Select]
(while (null (setq js (ssget '((0 . "LWPOLYLINE") (-4 . "<AND") (-4 . "&") (70 . 1) (-4 . ">") (90 . 2) (-4 . "<") (90 . 5) (-4 . "AND>"))))))
 (setq label (getstring "\nEnter label eg A "))
       (repeat (setq nb (sslength js))

................
"E" (itoa (setq count (1+ count))) " = "
now
label (itoa (setq count (1+ count))) " = "

You can do the setq label much better but simple for now.
Logged
A man who never made a mistake never made anything

mhy3sx

  • Newt
  • Posts: 120
Re: Analytic Calculation of area - Help to updatethe code
« Reply #2 on: March 24, 2023, 03:51:46 AM »
Thanks BIGAL .
Logged

DEVITG

  • Bull Frog
  • Posts: 480
Re: Analytic Calculation of area - Help to updatethe code
« Reply #3 on: March 26, 2023, 10:38:47 AM »
@mhy3sx

Just as I'm learning to  ssget filter 
Please clear me what is the meaning to
Code: [Select]
(WHILE (NULL (SETQ JS (SSGET '((0 . "LWPOLYLINE")
                                  (-4 . "<AND")
                                  (-4 . "&")
                                  (70 . 1)
                                  (-4 . ">")
                                  (90 . 2)
                                  (-4 . "<")
                                  (90 . 5)
                                  (-4 . "AND>"))))))
70 . 1 for closed
90 . 5 vertex

but why or for the ?
 90 .2

I did this  LWPOLYLINE , but it can not be select



Thanks in advance



 
Logged
Location @ Córdoba Argentina Using ACAD 2019  at Window 10

Lee Mac

  • Seagull
  • Posts: 12914
  • London, England
Re: Analytic Calculation of area - Help to updatethe code
« Reply #4 on: March 26, 2023, 06:53:03 PM »
The ssget filter is requiring DXF group 90 to be greater than 2 and less than 5, hence an alternative way to write it could be:
Code - Auto/Visual Lisp: [Select]
  1. (ssget '((0 . "LWPOLYLINE") (-4 . "&") (70 . 1) (-4 . "<OR") (90 . 3) (90 . 4) (-4 . "OR>")))
Logged

DEVITG

  • Bull Frog
  • Posts: 480
Re: Analytic Calculation of area - Help to updatethe code
« Reply #5 on: March 26, 2023, 07:17:10 PM »
Quote from: Lee Mac on March 26, 2023, 06:53:03 PM
The ssget filter is requiring DXF group 90 to be greater than 2 and less than 5, hence an alternative way to write it could be:
Code - Auto/Visual Lisp: [Select]
  1. (ssget '((0 . "LWPOLYLINE") (-4 . "&") (70 . 1) (-4 . "<OR") (90 . 3) (90 . 4) (-4 . "OR>")))

Hi LEE-MAC,  thanks for it .
So  if  (-4 . "<OR") (90 . 3) (90 . 4) (-4 . "OR>") . only it will select  Triangles or Quadrilateral 
Logged
Location @ Córdoba Argentina Using ACAD 2019  at Window 10

Lee Mac

  • Seagull
  • Posts: 12914
  • London, England
Re: Analytic Calculation of area - Help to updatethe code
« Reply #6 on: March 31, 2023, 10:32:24 AM »
Yes  :-)
Logged
Pages: [1] |   Go Up
« previous next »