Vai al contenuto

Recommended Posts

Buongiorno. Vorrei implementare questa lisp che ho trovato sul web. Si tratta di una lisp che crea una tabella con due colonne: ID della polilinea (o retino) selezionato, e la rispettiva area. Vorrei aggiungere una terza colonna con il colore della polilinea (o tratteggio) selezionata. Qualcuno riesce a capire come e dove intervenire?
 

;By Juan Villarreal
;Program will allow filtered object selection
;and provides dialog control for Unit Conversion and Unit precision
;allowing an additional conversion to be included as well.
;Output formats available include LineText Table, Autocad Table, Txt and Csv.
;Default 'From' drop-down is set according to insunits variable.

;-----------------------------------------DEFAULTS-------------------------------------------------

;Prefix
;Nil = "Area"
(setq pf "AREA");<-----------ENTER DEFAULT PREFIX
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;USE FIELDS?
;Nil = No
;"0" = No
;"1" = Yes

(setq fields "1");<-----------ENTER DEFAULT FIELDS OPTION

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;UNIT SELECTION
;0 = Inch
;1 = Foot
;2 = Yard
;3 = Acre
;4 = Mile
;5 = Millimeter
;6 = Centimeter
;7 = Meter
;8 = Kilometer
;9 = Microinch
;10 = Mil
;11 = Angstrom
;12 = Nanometer
;13 = Micron
;14 = Decimeter
;15 = Dekameter
;16 = Hectometer
;17 = Gigameter
;18 = Astronomical Unit
;19 = Light Year
;20 = Parsec

;Convert to drop-down
(if (zerop (getvar 'insunits))
(SETQ FROM 1));<--------------ENTER DEFAULT UNITS TO BASE CALCULATIONS ON IN CASE INSUNITS = 0

;Convert to drop-down
(SETQ TO 1);<-----------------ENTER DEFAULT CONVERSION UNIT

;Additional conversion drop-down
(SETQ SFX 2);<----------------ENTER DEFAULT ADDITIONAL CONVERSION UNIT

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;PRECISION SELECTION
;"0" thru "8"
;NIL to use luprec variable
;Example - "1" = 0.0
;        - "8" = 0.00000000

;'Convert to' Precision
(setq sel2prec NIL);<--------------------ENTER DEFAULT

;'Additional Conversion' Precision
(setq sel3prec NIL);<--------------------ENTER DEFAULT

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;Report Type
;"LineText" "Table" "Txt" "Csv"
;Nil = "LineText"

(setq reporttype "Csv");<--------------------ENTER DEFAULT

(if (vl-position reporttype '("Txt" "Csv"))(setq fields "0"))
;-------------------------------------------------------------------------------------------------




(defun GetObjectID ( obj doc)
  (if vla-getobjectidstring
        (vlax-invoke-method (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false)
        (itoa (vla-get-Objectid obj))
  )
)

(defun Acv21AddTable (comparelist TTL Titlelist listoflists / ActDoc *Space* ts i n p0 wlist ots sty)
 (setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object))
       *Space* (vla-get-ModelSpace ActDoc)
       sty (tblsearch "Style" (getvar 'textstyle))
       ots (getvar 'textsize)
       ts (vla-gettextheight (vla-item (vla-item (vla-get-dictionaries ActDoc) "ACAD_TABLESTYLE") "Standard") acDataRow))
       (setvar 'textsize ts)
(setq p0 (getpoint "\nSelect point to place table: ")
      tblObj
       (vla-addTable *Space*
         (vlax-3D-point p0)
         (+ (length listoflists) 2.0) 
         (length comparelist)
         (* 2.5 ts)
         (* 50 ts)
       )
      n 0
 );setq 
(vla-put-StyleName tblObj "Standard")
(vla-setText tblObj 0 0 TTL)
(GetTableWidths)
 (repeat (length comparelist)
   (vla-setText tblobj 1 n (nth (nth n comparelist) Titlelist))
   (setq n (1+ n))
 )
(setq i 2 n 0)
 (foreach x listoflists
  (repeat (length comparelist)
    (vla-setText tblobj i n (nth (nth n comparelist) x))
    (setq n (1+ n))
  )
  (setq n 0 i (1+ i))
 )

(setq i -1)
(mapcar
 '(lambda (x)
   (vla-setcolumnwidth tblobj (setq i (1+ i)) x)
 )
 wlist
)

(setvar 'textsize ots)
);defun 


(defun acwidthlist (wlist / acwlist)
 (repeat (length wlist)
  (setq acwlist (cons (apply '+ wlist) acwlist)
        wlist (reverse (cdr (reverse wlist))))
 )
 acwlist
)

(defun GetTableWidths ()
(setq wlist nil wlist
  (list
    (+ (apply 'max
        (mapcar
         (function (lambda (x)(- (caadr x)(caar x))))
         (mapcar (function (lambda (y) (textbox (list (cons 1 (nth 3 y)))))) (cons (list 0 1 2 "ID") alst))
        )
       )
     (* 2 ts))
    (+ (apply 'max
        (mapcar
         (function (lambda (x)(- (caadr x)(caar x))))
         (mapcar (function (lambda (y) (textbox (list (cons 1 (nth 4 y)))))) (cons (list 0 1 2 3 (nth to unitlist)) alst))
        )
       )
     (* 2 ts))
  )
)
(if realconversion2
 (setq wlist (append wlist
  (list
    (+ (apply 'max
        (mapcar
         (function (lambda (x)(- (caadr x)(caar x))))
         (mapcar (function (lambda (y) (textbox (list (cons 1 (nth 5 y)))))) (cons (list 0 1 2 3 4 (nth sfx unitlist)) alst))
        )
       )
    (* 2 ts))
   )
  ))
 )
)

;------------------------------------------------------------------------------------------------
  (defun lst->str (lst d1 d2);(Lee Mac)
    (if (cdr lst)
      (strcat d1 (car lst) d2 (lst->str (cdr lst) d1 d2))
      (strcat d1 (car lst))))

(defun list->string (lst);(Tony Tanzillo)
   (strlcat ","
      (mapcar 
        '(lambda (s)
           (if (numberp s) 
              (rtos s) 
              (strcat (chr 34) s (chr 34))
           )
         )
         lst
      )
   )
)

(defun Strlcat (delim strlst);(Tony Tanzillo)
   (apply 'strcat
      (cons 
         (car strlst)
         (mapcar
           '(lambda (s)
               (strcat delim s)
            )
            (cdr strlst)
         )
      )
   )
)
;------------------------------------------------------------------------------------------------

(defun AcV21AddLtTable (comparelist Title HeaderList listoflists / *Space* ts sty n p0 p1 p2 el1 dl cmpt oset wlist acwlist linelist )
 (setq *Space* (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-Acad-Object)))
        sty (tblsearch "Style" (getvar 'textstyle))
        n 0)
 (if (eq (setq ts (cdr (assoc 40 sty))) 0.0) (setq ts (getvar 'textsize)))
 (gettablewidths)
 (setq 
       p0 (getpoint "\nSelect point to place table: ")
       p1 (polar p0 0 (apply '+ wlist))
 )
 (setq el1 (vla-addline *Space* (vlax-3d-point p0) (vlax-3d-point p1)))
 (vla-ArrayRectangular el1 (+ (length listoflists) 3.0) 1.0 1.0 (* -2.5 ts) 0.0 0.0)
 (setq dl (* (+ (length listoflists) 2) (* 2.5 ts))
       p2 (polar p0 (* pi 1.5) dl)
       el1 (vla-addline *Space* (vlax-3d-point p0)(vlax-3d-point p2))
       n 0)
 (setq linelist (list (setq el1 (vla-addline *Space* (vlax-3d-point (polar p0 (* pi 1.5) (* 2.5 ts)))(vlax-3d-point p2)))))
 (repeat (length wlist)
  (and
   (nth n wlist)
   (vla-ArrayRectangular el1 1.0 2.0 1.0 0.0 (nth n wlist) 0.0)
   (setq el1 (vlax-ename->vla-object (entlast))
         n (1+ n)
   )
   (setq linelist (append linelist (list el1)))
  )
 )
 (mapcar 'vla-delete (list (car linelist)(car (reverse linelist))))
 (vla-addline *Space* (vlax-3d-point p1)(vlax-3d-point (polar p2 0 (apply '+ wlist))))
 (setq p2 (polar p0 (* pi 1.5) (* 6.25 ts))
       p2 (polar p2 0 (*  ts 0.5 (cdr (assoc 41 sty))))
       n 0
       cmpt 0
       oset (* ts -0.5)
 )
(setq acwlist (acwidthlist wlist))
 (repeat (length listoflists)
  (repeat (length comparelist)
    (setq tloc (list
                 (car (polar p2 0 (- (nth n acwlist)(nth n wlist))))
                 (+ (cadr (polar p2 0 (- (nth n acwlist)(nth n wlist)))) oset)
               )
          str (nth (nth n comparelist) (nth cmpt listoflists))
          n (1+ n)
    );setq
    (vla-addtext *Space* str (vlax-3d-point tloc) ts) 
  )
  (setq cmpt (1+ cmpt)
        oset (- oset (* 2.5 ts))
        n 0)
 )
 (setq p0 (polar p0 (* pi 1.5) (* 1.75 ts))
       p0 (polar p0 0 (*  ts 0.5 (cdr (assoc 41 sty))));;;
        n 0
 );setq
(vla-addtext *Space* Title
  (vlax-3d-point
    (polar p0 0
      (- (/ (car (reverse acwlist)) 2)
         (/ (car (mapcar (function (lambda (x)(distance (car x)(cadr x))))(list (textbox (list (cons 1 Title)(assoc 41 sty)))))) 2)
      )
    )
  )
  ts
)
(setq p0 (polar p0 (* pi 1.5) (* 2.5 ts)))
(repeat (length comparelist)
    (vla-addtext *Space* (nth (nth n comparelist) HeaderList)
                         (vlax-3d-point (polar p0 0 (- (nth n acwlist)(nth n wlist))))
                         ts)
    (setq n (1+ n))
)
);defun 


(defun Ac_MakeUnitList (key)
  (start_list key)
  (mapcar 'add_list unitlist)
  (end_list))

(defun ac_dialog (fname / fn)
    (if (setq wPath (findfile "ACAD.PAT"))
      (progn
        (setq wPath (vl-filename-directory wPath))
        (or (eq "\\" (substr wPath (strlen wPath)))
            (setq wPath (strcat wPath "\\")))
        (setq fn (open (strcat wPath fname) "w"))
        (foreach str
          '("button07 : button   { width = 7; alignment = centered; fixed_width = true; }"
            "text18 : text   { width = 18; alignment = centered; fixed_width = true; }"
            "text12 : text   { width = 12; alignment = centered; fixed_width = true; }"
            "text10 : text   { width = 10; alignment = centered; fixed_width = true; }"
            "AreaCalc : dialog { label = \"Area Calc v2.1\";"
            "   :row {"
            "     : text { label = \"Prefix:\" ; alignment = Centered;  }"
            "     : text { label = \"Initial #:\" ; alignment = Centered; }"
            "   }"
            "   :row {"
            "     :edit_box { key = \"Pfx\"; alignment = centered; edit_limit = 20; edit_width = 20; }"
            "     :edit_box { key = \"init\"; alignment = centered; edit_limit = 20; edit_width = 20; }"
            "   }"
            "   :row {"
            "     :toggle { key = \"kword\"; label = \"Label Areas\";  alignment = center; }"
          )
        (write-line str fn))
        (if (setq fieldstring (GetObjectId (vlax-ename->vla-object (ssname objlst 0)) ActDoc))
          (write-line  ":toggle { key = \"fields\"; label = \"Use Fields\";  alignment = center; }" fn)
        )
        (foreach str
            '("   }"
            "  :boxed_column { label = \"Area Conversion and Precision\";"
            "   :row {"
            "   :column {"
            "     spacer;"
            "     :text12 { label = \"Convert From:\";  width = 12; }"
            "     spacer;"
            "     :text12 { label = \"Convert To:\"; }"
            "     spacer;"
            "     :toggle { key = \"include\"; label = \"Add'l Conv.\";  alignment = centered; }"
            "     :text12 { label = \"Total:\"; }"
            "     :text12 { label = \"Converted:\"; }"
            "   }"
            "   :column {"
            "   :row {"
            "   :column {"
            "     spacer;"
            )
           (write-line str fn))
           (write-line 
           (if (= 0 (getvar  'insunits))
            "     :popup_list { key = \"Selection1\";alignment = left; edit_width = 10;}"    
            "     :text { key = \"Selection1\";alignment = left; width = 10;}"
           ) fn)
          (foreach str
          '("     :popup_list { key = \"Selection2\";alignment = left; edit_width = 10;}"
            "     :popup_list { key = \"Selection3\";alignment = left; edit_width = 10;}"
            "   }"
            "   :column {"
            "     spacer;"
            "     :text { key = \"CurrPrec\"; width = 10; alignment = left;}"
            "     spacer;"
            "     :popup_list { key = \"Sel2Prec\"; alignment = left; edit_width = 10;}"
            "     :popup_list { key = \"Sel3Prec\"; alignment = left; edit_width = 10;}"
            "   }}"
            "   :column {"
            "     :text { key = \"Original\";  alignment = left;  }"
            "     :text { key = \"Converted\"; alignment = left; }"
            "   }"
            "   }}"
            "  }"
            "  :boxed_row { label = \"Report Format\"; alignment = left;"
            "     :popup_list { key = \"Selection4\"; alignment = left; edit_width = 18;}"
            "     text18;"
            "  }"
            "    : button07 { key = \"accept\"; label = \"Done\"; fixed_width = true ; alignment = centered; is_default = true; is_cancel = true; }"
            "}")
          (write-line str fn))
        (close fn)
        t)
    nil)
)

(defun C:AC (/ objlst obj sarea verify labelkword ar pfa arealist txtobj olderror ts wlist
               Entpick ar ent hatb ActDoc vlamspace reportlist wpath ptlst vlaobjlst oldcmdecho
               p1 p2 fieldstring insu curve-obj ids Tot alst labellist)
(vl-load-com)
(setq olderror *error*
        oldcmdecho (getvar 'cmdecho)
)
(defun *error* ( msg )
        (princ (strcat "\n<" msg ">\n"))
              (setq *error* olderror)
              (setvar 'cmdecho oldcmdecho)
	(vla-EndUndoMark ActDoc)
        (princ)
);defun
(setq fname "AcAreaCalcv21.dcl"
        ts (getvar 'textsize)
        ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object))
        vlamspace (vla-get-ModelSpace ActDoc))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(setvar 'cmdecho 0)
(and in n (setq in (+ n in)))
(initget "ANY POLYLINE CIRCLE ELLIPSE REGION SPLINE HATCH")
(setq Entpick (getkword "\nObject Filter [ ANY / POLYLINE / CIRCLE / ELLIPSE / REGION / SPLINE / HATCH]: <ANY>")
 Tot 0
 n 0
 count 0
)

(while (not objlst)
(setq
 objlst
  (ssget
    (list
       (if (member entpick '("ANY" nil))
         (cons 0 "*POLYLINE,CIRCLE,ELLIPSE,REGION,SPLINE,HATCH")
         (cons 0 (strcat "*" Entpick))
       )
    )
  )
)
)
    
(while
  (setq n (1+ n) obj (ssname objlst (1- n)))
  (setq curve-obj (vlax-ename->vla-object obj))
  (if
   (or
    (member (vla-get-objectname curve-obj) '("AcDbRegion" "AcDbCircle" "AcDbHatch"))
    (vlax-curve-isClosed curve-obj)
    (not
     (member nil
      (mapcar
      '(lambda (x y)(eq x y))
       (vlax-curve-getstartpoint curve-obj)
       (vlax-curve-getendpoint curve-obj)
      )
     )
    )
   )
  (progn
  (vl-cmdf ".area" "o" obj)
  (setq ar (getvar "area")
          Tot (+ Tot ar)
          arealist (append arealist (list ar))
          vlaobjlst (append vlaobjlst (list curve-obj)))
          (vla-getboundingbox curve-obj 'll 'ur)
          (setq	ll (vlax-safearray->list ll)
	        ur (vlax-safearray->list ur)
	        pt (vlax-safearray->list
	            (vlax-variant-value
	             (vlax-3d-point
		      (polar ll (angle ll ur) (/ (distance ll ur) 2.0))
	             )
	            )
	           )
          )
          (setq ptlst (append ptlst (list pt)))
  );
  (and (setq n (1- n))(ssdel obj objlst))
 );if
)

(if (not arealist)(progn (alert "No closed objects selected.")(exit)))
(ac_dialog fname)
(setq dcl_id (load_dialog fname))
(if (not (new_dialog "AreaCalc" dcl_id))(exit))
(if (not pf)(setq pf "Area"))
(if (not fields)(setq fields "0"))
(if (not in)(setq in 1))
(if (not reporttype)(setq reporttype "LineText"))
(if (not sel2prec)(setq sel2prec (itoa (getvar 'luprec))))
(if (not sel3prec)(setq sel3prec (itoa (getvar 'luprec))))
(setq labelkword "Yes"
        Unitlist (list "SQ IN" "SQ FT" "SQ YDS" "ACRES" "SQ MILES"
                         "SQ MM" "SQ CM" "SQ M" "SQ KM" "SQ MICROIN"
                         "SQ MILS" "SQ ANGSTROMS" "SQ NANOM"
                         "SQ MICRONS" "SQ DECIM" "SQ DEKAM" "SQ HECTOM"
                         "SQ GIGAM" "SQ ASTRO UNITS" "SQ LIGHT YEARS" "SQ PARSECS")
        realconversion2 nil
        conversionlist
         (append
          (mapcar
            (function
              (lambda (x) (expt x 2))
            )
           (list
             1;                                ;Inch 1
             (/ 1.0 12)                      ;Foot 2
             (/ 1.0 (* 3 12))                ;Yard 10
             (/ 1.0 (* (sqrt 43560) 12));Acre ;extra unit included
             (/ 1.0 (* 5280 12))          ;Mile 3
             (* 10.0 2.54)                 ;Millimeter 4
             2.54                             ;Centimeter 5
             (* (expt 10.0 -2) 2.54)    ;Meter 6
             (* (expt 10.0 -5) 2.54)    ;Kilometer 7
             (expt 10.0 6)                 ;Microinch 8
             (expt 10.0 3)                 ;Mil 9
             (* (expt 10.0 8) 2.54)      ;Angstrom 11
             (* (expt 10.0 7) 2.54)      ;Nanometer 12
             (* (expt 10.0 4) 2.54)      ;Micron 13
             (* (expt 10.0 -1) 2.54)      ;Decimeter 14
             (* (expt 10.0 -3) 2.54)     ;Dekameter 15
             (* (expt 10.0 -4) 2.54)     ;Hectometer 16
             (* (expt 10.0 -11) 2.54)   ;Gigameter 17
           )
         )
         (list (* (expt 10.0 -26) 2.88280893);Astronomical Unit 18
               (* (expt 10.0 -36) 7.20836294);Light Year 19
               (* (expt 10.0 -37) 6.77587822);Parsec 20
         ))
       inverseconversionlist
        (mapcar
          (function
            (lambda (x) (/ 1.0 x))
          )
         conversionlist
        )
)
(if fields (set_tile "fields" fields))
(set_tile "Pfx" pf)
(set_tile "init" (itoa in))     
(set_tile "kword" "1")
(set_tile "Converted" (rtos Tot 2 (atoi sel2prec)))
(set_tile "include" "0")
(set_tile "CurrPrec" (strcat "  " (rtos 0)))
(set_tile "Sel2Prec" sel2prec)
(set_tile "Sel3Prec" sel3prec)
(mapcar 'Ac_MakeUnitList '("Selection1" "Selection2" "Selection3"))
  (mapcar
    (function (lambda (x)
      (start_list x)
      (mapcar 'add_list (list "0" "0.0" "0.00" "0.000" "0.0000" "0.00000" "0.000000" "0.0000000" "0.00000000"))
      (end_list)
    ))
    (list "Sel2Prec" "Sel3Prec")
  )
(setq insu (getvar 'insunits))
(if (or (/= insu 0)(not from))
 (setq from
(cond
  ((= insu 1) 0)
  ((= insu 2) 1)
  ((< insu 10) (1+ insu))
  ((= insu 10)  2)
  ((> insu 10) insu)
)))
(if (not to)(setq to from))

(if (and (zerop insu) from)
    (set_tile "Selection1" (itoa from))
    (set_tile "Selection1" (nth from Unitlist))
)

(and
  to (set_tile "Selection2" (itoa to))
  (setq realconversion (* (nth from inverseconversionlist) (nth to conversionlist)))
  (set_tile "Converted" (rtos (* realconversion Tot) 2 (atoi sel2prec)))
  sfx (set_tile "Selection3" (itoa sfx))
  (set_tile "include" "1")
  (setq realconversion2 (* (nth sfx conversionlist)(nth to inverseconversionlist)))
)
  (set_tile "Original" (rtos Tot))
  (start_list "Selection4")(mapcar 'add_list (setq reportlist (list "LineText" "Table" "Txt" "Csv")))(end_list)
  (set_tile "Selection4" (itoa (vl-position reporttype reportlist)))
(action_tile "Pfx"
  (vl-prin1-to-string
    (quote
      (setq pf $value))))

(action_tile "init"
  (vl-prin1-to-string
    (quote
      (progn
        (if (= $value "")
        (setq in 1)
        (setq in (atoi $value)))
      ))))
(action_tile "kword"
  (vl-prin1-to-string
    (quote
      (progn
        (setq labelkword (if (eq $value "1") "Yes" "No"))
      ))))
(action_tile "fields"
  (vl-prin1-to-string
    (quote
      (progn
        (if (member reporttype '("Txt" "Csv"))
            (and (setq fields "0")(set_tile "fields" fields))
            (setq fields $value)
        )
      ))))
(action_tile "Selection1"
  (vl-prin1-to-string
    (quote
      (progn
        (setq from (fix (atof $value)))
        (setq to (fix (atof (get_tile "Selection2"))))
        (setq realconversion (* (nth from inverseconversionlist) (nth to conversionlist)))
        (if realconversion2 (setq realconversion2 (* (nth sfx conversionlist)(nth to inverseconversionlist))))
        (set_tile "Converted" (rtos (* Tot realconversion) 2 (atoi sel2prec)))
      ))))

(action_tile "Selection2"
  (vl-prin1-to-string
    (quote
      (progn
        (setq to (fix (atof $value)))
        (setq from (fix (atof (get_tile "Selection1"))))
        (setq realconversion (* (nth from inverseconversionlist) (nth to conversionlist)))
        (if realconversion2 (setq realconversion2 (* (nth sfx conversionlist)(nth to inverseconversionlist))))
        (set_tile "Converted" (rtos (* Tot realconversion) 2 (atoi sel2prec))) 
      ))))

(action_tile "Sel2Prec"
  (vl-prin1-to-string
    (quote
      (progn
        (setq sel2prec $value)
        (set_tile "Converted" (rtos (* Tot realconversion) 2 (atoi sel2prec)))
      ))))

(action_tile "include"
  (vl-prin1-to-string
    (quote
      (progn
        (setq sfx (fix (atof (get_tile "Selection3")))
                realconversion2
        (if (eq $value "1")
          (* (nth sfx conversionlist)(nth to inverseconversionlist))
          (progn (setq sfx nil) nil)
        ))))))

(action_tile "Selection3"
  (vl-prin1-to-string
    (quote
      (progn
        (set_tile "include" "1")
        (setq sfx (fix (atof $value)))
        (setq realconversion2 (* (nth sfx conversionlist)(nth to inverseconversionlist)))
      ))))

(action_tile "Sel3Prec"
  (vl-prin1-to-string
    (quote
      (progn
        (setq sel3prec $value) 
      ))))

(action_tile "Selection4"
  (vl-prin1-to-string
    (quote
      (progn
        (setq reporttype (nth (fix (atof $value)) reportlist))
        (if (member reporttype '("Txt" "Csv"))(setq fields "0"))
        (set_tile "fields" fields)
      ))))

(action_tile "accept"
  (vl-prin1-to-string
    (quote
      (progn
	(done_dialog)
      ))))

(start_dialog)
(unload_dialog dcl_id)
  (and (= labelkword "Yes")
     (foreach x ptlst
      (setq TextENAME
        (vla-addMText vlamspace
          (vlax-3d-point x)
          0.0
          (strcat pf " " (itoa (1- (+ in (1+ count)))))
        );vla
        count (1+ count)
      ) 
      (not (vla-put-height textename (getvar 'textsize)))
      (not (vla-put-rotation textename (- 0 (getvar 'viewtwist))))
      (not (vla-put-attachmentpoint textename acAttachmentPointMiddleCenter))
      (not (vla-put-insertionpoint textename (vlax-3d-point x)))
      (setq labellist (append labellist (list textename)))
    )
  )

  (setq n 0)
  (repeat (sslength objlst)
    (setq sarea (nth n arealist) n (1+ n)
            ar
(list
(if (and (eq fields "1")(= labelkword "Yes"))
 (strcat "%<\\AcObjProp.16.2 Object(%<\\_ObjId " (GetobjectId (nth (1- n) labellist) ActDoc) ">%).TextString>%")
 (strcat pf " " (itoa (1- (+ in n)))))
 (if (and (eq fields "1")(setq fieldstring (GetObjectId (nth (1- n) vlaobjlst) ActDoc)))
   (strcat
    "%<\\AcExpr (%<\\AcObjProp.16.2 Object(%<\\_ObjId "
    fieldstring
    ">%).Area \\f \"%lu2%qf1%ps\">% *"
    (rtos realconversion 2 30)
      ") \\f \"%lu2%pr"
     sel2prec "\>%"
   )
   (strcat (rtos (setq newnumb (* realconversion sarea)) 2 (atoi sel2prec)))
 )
 (if (and (eq fields "1") fieldstring realconversion2)
  (strcat
    "%<\\AcExpr (%<\\AcObjProp.16.2 Object(%<\\_ObjId "
    fieldstring
    ">%).Area \\f \"%lu2%qf1%ps\">% * "
    (rtos realconversion 2 30)
    " * "
    (rtos realconversion2 2 30)
    ") \\f \"%lu2%pr"
    sel3prec "\">%"
  )
  (if realconversion2 (strcat (rtos (* realconversion2 newnumb) 2 (atoi sel3prec))) "")
 )
 (strcat pf " " (itoa (1- (+ in n))))
 (strcat (rtos (setq newnumb (* realconversion sarea)) 2 (atoi sel2prec)))
 (if realconversion2 (strcat  (rtos (* realconversion2 newnumb) 2 (atoi sel3prec))) "")
)
          alst (append alst ( list ar )) ids (append ids (list fieldstring)))
  );repeat
  (if (= reporttype "LineText")
  (setq alst 
   (append alst (list (list "TOTAL" 
              (if (eq fields "1")
                (if (= 1 (length Ids))
                 (strcat
                  "%<\\AcExpr (%<\\AcObjProp.16.2 Object(%<\\_ObjId "
                  fieldstring
                  ">%).Area \\f \"%lu2%qf1%ps\">% *"
                 (rtos realconversion 2 30)
                 ") \\f \"%lu2%pr"
                 sel2prec "\>%")

                  (strcat "%<\\AcExpr ("
                   (lst->str Ids
                             " %<\\AcObjProp Object(%<\\_ObjId "
                             ">%).Area >% +"
                   )
                    ">%).Area \\f \"%lu2%qf1%ps\">%) *"
                    (rtos realconversion 2 30)
                    " \\f \"%lu2%pr" sel2prec "\>%")
                )
               (rtos (setq newnumb (* Tot realconversion)) 2 (atoi sel2prec))
	      )
             (if (and (eq fields "1") realconversion2)
                (if (= 1 (length Ids))
                 (strcat
                  "%<\\AcExpr (%<\\AcObjProp.16.2 Object(%<\\_ObjId "
                  fieldstring
                 ">%).Area \\f \"%lu2%qf1%ps\">% * "
                  (rtos realconversion 2 30)
                 " * "
                 (rtos realconversion2 2 30)
                 ") \\f \"%lu2%pr"
                  sel3prec "\">%")

                  (strcat "%<\\AcExpr ("
                   (lst->str Ids
                             " %<\\AcObjProp Object(%<\\_ObjId "
                             ">%).Area >% +"
                   )
                    ">%).Area \\f \"%lu2%qf1%ps\">%) *"
                    (rtos realconversion 2 30) " * "
                    (rtos realconversion2 2 30)
                    " \\f \"%lu2%pr" sel3prec "\">%")
                )
                (if realconversion2 (rtos (* realconversion2 newnumb) 2 (atoi sel3prec)) "")
            )
	    "TOTAL"
            (rtos (setq newnumb (* Tot realconversion)) 2 (atoi sel2prec))
            (if realconversion2 (rtos (* realconversion2 newnumb) 2 (atoi sel3prec)) "")))
  )))

(cond
((= reporttype "Txt")
 (setq wPath (vl-filename-directory (findfile "ACAD.PAT")))
  (or (eq "\\" (substr wPath (strlen wPath)))
    (setq wPath (strcat wPath "\\")))
  (setq f (open (strcat wPath "Area Report." reporttype) "w"))
  (foreach x alst (write-line (strcat "\n" (car x) " = " (cadr x) " " (nth to unitlist)
     (if realconversion2 (strcat " " (caddr x) " " (nth sfx unitlist)) "")) f))
  (write-line
    (if realconversion2
      (strcat "\nTotal = " (rtos (setq newnumb (* Tot realconversion)) 2 (atoi sel2prec)) " "
        (nth to unitlist) " (" (rtos (* realconversion2 newnumb) 2 (atoi sel3prec)) " " (nth sfx unitlist) ")"
      )
      (strcat "\nTotal = " (rtos (setq newnumb (* Tot realconversion)) 2 (atoi sel2prec)) " " (nth to unitlist))
    )
    f
  );write-line
  (close f)
(startapp "explorer" (strcat wPath "Area Report." reporttype))
)
((= reporttype "Csv")
 (setq wPath (vl-filename-directory (findfile "ACAD.PAT")))
  (or (eq "\\" (substr wPath (strlen wPath)))
    (setq wPath (strcat wPath "\\")))
  (setq f (open (strcat wPath "Area Report." reporttype) "w"))
  (write-line "Area Report" f)
  (write-line (list->string (list "ID" (nth to unitlist) (if realconversion2 (nth sfx unitlist) ""))) f)
  (foreach x alst (write-line (list->string (list (car x)(cadr x)(if realconversion2 (caddr x) ""))) f))
  (write-line (list->string
              (list "Total" (rtos (setq newnumb (* Tot realconversion)) 2 (atoi sel2prec))
                            (if realconversion2 (rtos (* realconversion2 newnumb) 2 (atoi sel3prec)) ""))) f)
  (close f)
(startapp "explorer" (strcat wPath "Area Report." reporttype))
)
((= reporttype "LineText")
 (Acv21AddLtTable
   (if realconversion2 '(0 1 2) '(0 1))
    "AREA TABLE"
   (if realconversion2 (list "ID" (nth to unitlist)(nth sfx unitlist))(list "ID" (nth to unitlist)))
   alst
 ))
((= reporttype "Table")
 (Acv21AddTable
   (if realconversion2 '(0 1 2) '(0 1))
    "AREA TABLE"
   (if realconversion2 (list "ID" (nth to unitlist)(nth sfx unitlist))(list "ID" (nth to unitlist)))
   (append alst (list (list "TOTAL" (strcat "%<\\AcExpr (Sum(B3:B" (itoa (+ (length alst) 2)) ")) \\f %lu2%pr" sel2prec ">%")
                (if realconversion2 (strcat "%<\\AcExpr (Sum(C3:C" (itoa (+ (length alst) 2)) ")) \\f %lu2%pr" sel3prec ">%") "")
                "TOTAL"
                (rtos (setq newnumb (* Tot realconversion)) 2 (atoi sel2prec))
                (if realconversion2 (rtos (* realconversion2 newnumb) 2 (atoi sel3prec)) ""))))             
 ))
)
(setq *error* olderror)
(setvar 'cmdecho oldcmdecho)
(vla-EndUndoMark ActDoc)
(princ)
);defun

 

AC_AREA-CALC_v2.1.lsp

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

Crea un account o accedi per commentare

Devi essere un utente per poter lasciare un commento

Crea un account

Registrati per un nuovo account nella nostra comunità. è facile!

Registra un nuovo account

Accedi

Hai già un account? Accedi qui.

Accedi ora


  • Navigazione recente   0 utenti

    Non ci sono utenti registrati da visualizzare in questa pagina.

×