Surface

[monkiki]

Salut à tous,

J'ai récupéré un lisp (Rea-att) sur les surfaces de Patrick. Et ça marche impeccable, sauf que je travaille en mm et j'aimerais que la surface trouvée soit divisée par 1/1000000. Je suis qu'un simple utilisateur d'AutoCAD. Donc pour ce qui concerne le langage Lisp, je ne connais pas grand chose! Je sais qu'il faut modifier sur une ligne, mais laquelle???

Merci d'avance!

;;;=================================================================

;;;

;;; REA-ATT.LSP V2.00

;;;

;;; Associer un Attribut à une poly fermée

;;;

;;; Copyright © Patrick_35

;;;

;;;=================================================================

 

(defun modif_poly(obj rea arg-list)

(if (and (vlax-read-enabled-p obj)(vlax-read-enabled-p (vlr-data rea)))

(vla-put-textstring (vlr-data rea) (strcat (rtos (/ (vla-get-area obj) 10000) 2 2) "M2"))

(vlr-remove rea)

)

)

 

(defun effacer_pt(obj rea arg-list)(setq aa obj bb rea)

(vlax-ldata-delete obj "Patrick_35" (vlr-data rea))

(vlax-ldata-delete (vlr-data rea) "Patrick_35" obj)

(vlr-remove rea)

)

 

(defun c:srea-att(/ sel rec)

(if (setq sel (car (nentsel "Sélection d'un objet lié : ")))

(progn

(setq sel (vlax-ename->vla-object sel))

(if (setq rec (vlax-ldata-get sel "Patrick_35"))

(progn

(mapcar 'vlr-remove

(vl-remove-if-not

'(lambda (x) (if (eq (type (vlr-data x)) 'VLA-OBJECT)

(if (vlax-read-enabled-p (vlr-data x))

(or (eq (vla-get-ownerid (vlr-data x)) (vla-get-ownerid sel))

(eq (vla-get-ownerid (vlr-data x)) (vla-get-ownerid rec))

)

)

)

)

(cdr (car (vlr-reactors :vlr-object-reactor)))

)

)

(vlax-ldata-delete sel "Patrick_35" rec)

(vlax-ldata-delete rec "Patrick_35" sel)

(princ "\nLiaison effacée.")

)

(alert "Pas de liaison")

)

)

)

(princ)

)

 

(defun c:rea-att(/ n sel_poly sel_text)

(while (not sel_poly)

(setq sel_poly (car (entsel "\nSélection de la polyligne/spline/cercle : ")))

(if sel_poly

(if (member (cdr (assoc 0 (entget sel_poly))) '("POLYLINE" "LWPOLYLINE" "SPLINE" "CIRCLE"))

(progn

(setq sel_poly (vlax-ename->vla-object sel_poly))

(if (/= (vla-get-objectname sel_poly) "AcDbCircle")

(if (= :vlax-false (vla-get-closed sel_poly))

(progn

(alert "Cette Polyligne/Spline n'est pas fermée")

(setq sel_poly nil)

)

)

)

(if sel_poly

(if (vlax-ldata-get sel_poly "Patrick_35")

(progn

(alert "Polyligne/Spline/Cercle déjà associé à un attribut")

(setq sel_poly nil)

)

)

)

)

(progn

(alert "Ce n'est pas une Polyligne/Spline/Cercle")

(setq sel_poly nil)

)

)

)

)

(if sel_poly

(progn

(while (not sel_text)

(setq sel_text (car (nentsel "\nSélection de l'attribut : ")))

(if sel_text

(if (= (cdr (assoc 0 (entget sel_text))) "ATTRIB")

(progn

(setq sel_text (vlax-ename->vla-object sel_text))

(if (vlax-ldata-get sel_text "Patrick_35")

(progn

(alert "Attribut déjà associé à une Polyligne/Spline/Cercle")

(setq sel_text nil)

)

)

)

(progn

(setq sel_text nil)

(alert "Ce n'est pas un attribut")

)

)

)

)

(if sel_text

(progn

(vlr-object-reactor (list sel_poly) sel_text '((:vlr-modified . modif_poly)(:vlr-erased . effacer_pt)))

(vlr-object-reactor (list sel_text) sel_poly '((:vlr-erased . effacer_pt)))

(vlax-ldata-put sel_poly "Patrick_35" sel_text)

(vlax-ldata-put sel_text "Patrick_35" sel_poly)

(vla-put-textstring sel_text (strcat (rtos (/ (vla-get-area sel_poly) 10000) 2 2) "M2"))

)

)

)

)

(princ)

)

 

(defun refaire_reacteurs(/ entp entt)

(vl-load-com)

(if (not appli_patrick_35)

(progn

(setq appli_patrick_35 (ssget "x" (list (cons 102 "{ACAD_XDICTIONARY"))))

(if appli_patrick_35

(progn

(setq n 0)

(while (setq entp (ssname appli_patrick_35 n))

(setq entp (vlax-ename->vla-object entp))

(if (setq entt (vlax-ldata-get entp "Patrick_35"))

(progn

(vla-put-textstring entt (strcat (rtos (/ (vla-get-area entp) 10000) 2 2) "M2"))

(vlr-object-reactor (list entp) entt '((:vlr-modified . modif_poly)(:vlr-erased . effacer_pt)))

(vlr-object-reactor (list entt) entp '((:vlr-erased . effacer_pt)))

)

(vlax-ldata-delete entp "Patrick_35")

)

(setq n (1+ n))

)

)

)

)

)

(princ)

)

 

(refaire_reacteurs)

(princ "\nREA-ATT.LSP chargé. Tapez REA-ATT ou SREA-ATT pour l'exécuter")

(princ)

[(gile)]

Salut,

 

Il y a trois fois l'expression :

 

(strcat (rtos (/ (vla-get-area ...) 10000) 2 2) "M2")

 

Il suffit de remplacer 10000 par 1000000 ou 1e6

[monkiki]

Merci Gile! ça marche!

[Steven]

Pourquoi n'utilises tu pas les champs?

Il y a un champs pour les surfaces et tu peux faire en sorte que l'uminté se mette dans ton unité de travail.

[(gile)]

Ou encore un champ dynamique dans un attribut avec Pline_block

[monkiki]

oui, tu as raison Steven! On peut utiliser un champs mais, avec le lisp "rea-att" de Patrick, je pense que je gagne en terme de temps. Parce que si tu dois créer par exemple 5 surfaces dans 5 bureaux, tu dois refaire à chaque fois l'opération avec le champs avec un facteur de conversion, alors qu'avec le lisp, il suffit de copier les attributs dans chaque pièce et rentrer la commande pour modifier la surface de chaque pièce...C'est ce que je pense. Peut-être que j'ai tort!!

 

Pour le champ dyn dans un attribut avec pline_block de Gile, comment pourrais-je récupérer le fichier Lisp et DCL? Merci par avance!

 

 

[(gile)]

 

Sur le lien donné plus haut, copier les codes (séparément), les coller dans le bloc-note et suivre les instructions données ici.

[monkiki]

Merci Gile! ça marche pour pline_block!

J'ai trouvé un autre Lisp et DCL (DDAREA)pour la surface aussi. C'est très intéressant aussi, et je trouve pas la ou les lignes pour diviser par 1000000. Le deuxième problème lorsque j'écris un nom de pièce dans la boîte de dialogue, il me donne tjs un chiffre derrière. Par exemple: bureau0 ou bureau1 ....Pour écrire simplement le nom des pièces, comment faire?

Ci-joint le fichier DCL et LISP

 

ddarea : dialog {

value = "Configuartion DDarea";

key = "title";

 

:row {

: boxed_column {

label="Configuration du texte: ";

 

: edit_box {

label = "Nom de la surface: ";

key = "obj";

fixed_width = true;

}

 

 

: edit_box {

label = "N° de départ: ";

fixed_width = true;

key = "num";

}

 

: toggle {

label = "Ecrire les valeurs";

key = "lbl";

}

 

: edit_box {

label = "Hauteur du texte: ";

fixed_width = true;

key = "thei";

}

 

: edit_box {

label = "Angle du texte: ";

fixed_width = true;

key = "trot";

}

: toggle {

label = " 2 chiffres après la virgule ";

fixed_width = true;

key = "decim";

}

}//fin box column

 

:spacer{

width=0;

}

 

: column{

 

: boxed_column{

label = "Label";

key = "bc";

 

: toggle {

label = "Numérotation ";

key = "ID";

}

 

: toggle {

label = "Aire en m2";

key = "area";

}

 

: toggle {

label = "Périmètre ";

key = "peri";

}

 

}// fin box column label

 

: boxed_column{

label = "Fichier";

key = "Fichbc";

:button {

label = "Fichier de sortie";

key = "out";

width=10;

}

 

: toggle {

label = "Création du fichier de sortie ";

key = "sof";

}

}//fin box column fichier

}}

 

: boxed_row{

label = "Options de Contour";

:column {

: toggle {

label = "Conserver les contours ";

key="rbl";

}

}

}

 

:spacer{

height=1;

}

:row{

:spacer{

width=3;

}

:button{

label="Choix des objets";

key="accept";

}

:button{

label="Contour";

key="acceptb";

}

:button{

label="Digitalisation";

key="acceptd";

}

cancel_button;

 

:spacer{

width=3;

}

}//fin row du bas

 

}

 

 

 

 

 

RESULTAT_calcul : dialog { label = "RESULTAT";

: edit_box { key = "SOMME";

edit_width = 70;

}

ok_button;

}

 

Fichier LISP

 

;source originale de Brian Strandberg

;modifié par PIerre Louiset

; Global Variables

(setq BW_AREA_OBJ "Surface : ")

(setq ADDT 0)

(setq BW_AREA_THEI (* 1 (getvar "dimscale")))

(setq BW_AREA_TROT 0)

(setq BW_AREA_AREA 1)

(setq BW_AREA_PERI 0)

(setq BW_AREA_ID 1)

(setq BW_AREA_LBL 1)

(setq BW_AREA_AREAC 0)

(setq BW_AREA_RBL 0)

(setq BW_AREA_SOF 0)

(setq decimal 0)

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setq BW_AREA_FD "e:/ddarea.txt")

 

 

;;; edit this to change the default location of the output file

 

(defun BW_AREA (/ A TEXT NUM LEN C D E F H TOTAL TOTALP)

(setvar "hpbound" 1)

(setvar "cmdecho" 0)

(if (= 1 BW_AREA_SOF)

(setq FD (open BW_AREA_FD "a"))

()

) ;_ end of if

(setq TOTAL 0)

(setq TOTALP 0) ; Select objects or boundary *******************

;;; (if (/= RET 2)

(if (= RET 1)

(setq A (ssget))

 

) ;_ end of if

(if (= ret 2)

(progn (BW_BOUND) (setq A BW_BOUND_SET))

)

 

(if (= RET 3)

(progn (ere) (setq A (ssget)))

)

 

(setq TSH (cdr (assoc 40 (tblsearch "style" (getvar "textstyle")))))

(if (= TSH 0)

(princ)

(command "_style" "" "" "0" "" "" "" "" "")

) ;_ end of if

(setq NUM 0)

(setq LEN (sslength A))

(if (= 1 BW_AREA_SOF)

(progn (princ "\n\n\n" FD)

(if (= 1 BW_AREA_ID)

(princ BW_AREA_OBJ FD)

()

) ;_ end of if

(if (= 1 BW_AREA_AREA)

(princ ",m2" FD)

()

) ;_ end of if

 

(if (= 1 BW_AREA_PERI)

(princ ",Périmetre" FD)

()

) ;_ end of if

) ;_ end of progn

()

) ;_ end of if

(repeat LEN

(setq C (ssname A NUM))

(setq D (entget C))

(setq E (cdr (assoc -1 D)))

(command "_area" "_O" E)

(princ "\n")

(if (= 1 BW_AREA_SOF)

(progn

(princ "\n " FD)

(if (= 1 BW_AREA_ID)

(if (not BW_AREA_SOF)

(princ BW_AREA_OBJ FD)

()

) ;_ end of if

()

) ;_ end of if

(setq QQ (+ ADDT NUM))

(if (= 1 BW_AREA_ID)

(princ (strcat "" (itoa QQ)) FD)

()

) ;_ end of if

(if (= 1 BW_AREA_AREA)

(if (= 1 decimal)

(progn (princ (strcat "," (rtos (getvar "area") 2 2)) FD))

(progn (princ (strcat "," (rtos (getvar "area") 2 0)) FD))

)

;;; (progn (princ (strcat "," (rtos (getvar "area"))) FD))

()

) ;_ end of if

 

(if (= 1 BW_AREA_PERI)

(if (= 1 decimal)

(progn (princ (strcat "," (rtos (getvar "Perimeter") 2 2)) FD))

(progn (princ (strcat "," (rtos (getvar "Perimeter") 2 0)) FD))

)

 

;;; (progn (princ (strcat "," (rtos (getvar "Perimeter"))) FD))

 

()

) ;_ end of if

(setq TOTALP (+ TOTALP (getvar "perimeter")))

(setq TOTAL (+ TOTAL (getvar "AREA")))

) ;_ end of progn

()

) ;_ end of if

(if (= 1 BW_AREA_LBL)

(BW-LABEL)

()

) ;_ end of if

(setq NUM (+ 1 NUM))

) ;_ end of repeat

(if (and (= RET 2) (= BW_AREA_RBL 0))

(command "_erase" A "")

()

) ;_ end of if

(if (= 1 BW_AREA_SOF)

(progn

(if (= 1 BW_AREA_AREA)

(progn (princ "\nTotal des surfaces sélectionnées : " FD)

(princ TOTAL FD)

)

()

) ;_ end of IF

 

(if (= 1 BW_AREA_PERI)

(progn

(princ "\nTotal des périmètres des surfaces sélectionnées : "

FD

)

(princ TOTALP FD)

)

()

) ;_ end of IF

) ;_ end of progn

()

) ;_ end of if

(if (/= TSH 0.0)

(command "_style" "" "" TSH "" "" "" "" "")

()

) ;_ end of if

(setq ADDT (+ ADDT NUM)) ; prevent repeating numbers

(if (= 0 BW_AREA_SOF)

()

(close FD)

) ;_ end of if

(princ)

) ;_ end of defun

 

 

 

 

(defun BW-LABEL (/ TINS)

(redraw E 3)

(setq TINS (getpoint "\nPoint d'insertion du Texte : "))

(if (= 1 BW_AREA_ID)

(progn (command "_text"

"_m"

TINS

BW_AREA_THEI

BW_AREA_TROT

(strcat BW_AREA_OBJ (itoa (+ ADDT NUM)))

) ;_ end of command

) ;_ end of progn

(command "_text" "_m" TINS BW_AREA_THEI BW_AREA_TROT "")

) ;_ end of if

(if (= 1 BW_AREA_AREA)

(if (= 1 decimal)

(command "_text" "" (strcat (rtos (getvar "area")2 2) " m2"))

(command "_text" "" (strcat (rtos (getvar "area")2 0) " m2"))

)

()

) ;_ end of if

 

(if (= 1 BW_AREA_PERI)

(if (= 1 decimal)

(command "_text" "" (strcat (rtos (getvar "Perimeter")2 2) " m"))

(command "_text" "" (strcat (rtos (getvar "Perimeter")2 0) " m"))

)

()

) ;_ end of if

(setq BW_TEMP (cdr (assoc -1 (entget (entlast)))))

(redraw E 4)

) ;close routine

 

 

(defun BW_GF (/)

(setq

BW_FD (getfiled "Fichier de sortie " BW_AREA_FD "TXT" (+ 1 2 4))

)

) ;_ end of defun

 

 

(defun BW_AREA_SETUP (/)

(set_tile "obj" BW_AREA_OBJ)

(set_tile "num" (itoa ADDT))

(set_tile "thei" (rtos BW_AREA_THEI))

(set_tile "trot" (rtos BW_AREA_TROT))

(set_tile "ID" (itoa BW_AREA_ID))

(set_tile "area" (itoa BW_AREA_AREA))

(set_tile "peri" (itoa BW_AREA_PERI))

(set_tile "lbl" (itoa BW_AREA_LBL))

(set_tile "rbl" (itoa BW_AREA_RBL))

(set_tile "sof" (itoa BW_AREA_SOF))

 

(set_tile "decim" (itoa decimal))

 

 

(if (= BW_AREA_LBL 0)

(progn (mode_tile "thei" 1) (mode_tile "trot" 1))

()

) ;_ end of if

) ;_ end of defun

 

 

 

(defun BW_LBL1 ($VAL /)

(if (= $VAL "0")

(progn (mode_tile "thei" 1) (mode_tile "trot" 1))

(progn (mode_tile "thei" 0) (mode_tile "trot" 0))

) ;_ end of if

(setq BW_AREA_LBL (atoi $VAL))

) ;_ end of defun

 

 

 

 

 

(defun C:DDAREA (/)

(setq DH (load_dialog "ddarea"))

(if (not (new_dialog "ddarea" DH))

(exit)

)

 

(BW_AREA_SETUP)

(action_tile "accept" "(done_dialog 1)")

(action_tile "acceptb" "(done_dialog 2)")

(action_tile "acceptd" "(done_dialog 3)")

(action_tile "cancel" "(exit)(exit)")

(action_tile

"obj"

"(progn (setq bw_area_obj $value)(bw_area_setup))"

)

(action_tile

"num"

"(progn (setq addt (atoi $value))(bw_area_setup))"

)

(action_tile

"thei"

"(progn (setq bw_area_thei (atof $value))(bw_area_setup))"

)

(action_tile "decim"

"(progn (setq decimal (atoi $value))(bw_area_setup))"

)

(action_tile

"trot"

"(progn (setq bw_area_trot (atof $value))(bw_area_setup))"

)

(action_tile

"ID"

"(progn (setq bw_area_id (atoi $value))(bw_area_setup))"

)

(action_tile

"area"

"(progn (setq bw_area_area (atoi $value))(bw_area_setup))"

)

(action_tile

"areac"

"(progn (setq bw_area_areac (atoi $value))(bw_area_setup))"

)

(action_tile

"peri"

"(progn (setq bw_area_peri (atoi $value))(bw_area_setup))"

)

(action_tile "lbl" "(bw_lbl1 $value)")

(action_tile "out" "(bw_gf)")

(action_tile

"rbl"

"(progn (setq bw_area_rbl (atoi $value))(bw_area_setup))"

)

(action_tile

"sof"

"(progn (setq bw_area_sof (atoi $value))(bw_area_setup))"

)

 

(setq RET (start_dialog))

(BW_AREA)

) ;_ end of defun

 

 

 

(defun BW_BOUND (/ A C DQ B1)

(setq B1 1)

(setq BW_BOUND_SET NIL)

(setq DQ NIL)

(setq A (entlast)) ;Selecting Entities Start********%%%%%%%%

(princ

"\nPoints dans les surfaces fermées à mesurer, ENTREE pour sortir: "

)

(while (/= NIL B1)

(setq B1 (getpoint))

(if (/= NIL B1)

(command "_boundary" B1 "")

()

) ;_ end of if

(if (= BW_AREA_BV 1)

(progn (setq KB (entlast))

(princ "\n")

(initget "Yes No")

(setq KBL (getkword "Conserver le contour? (Yes or No) "))

(if (= KBL "N")

(command "_erase" KB "")

()

) ;_ end of if

) ;close progn

()

) ;close if

) ; end while

(setq D (ssget "L"))

(setq C (entnext A))

(while (/= NIL C)

(setq DQ (ssadd C D))

(setq C (entnext C))

)

;Selecting Entities End*********%%%%%%%%%

(setq BW_BOUND_SET DQ)

(if (= NIL BW_BOUND_SET)

(progn (alert "Un contour n'est pas fermé\n\n FIN du Programme")

(exit)

) ;_ end of progn

()

) ;_ end of if

) ;_ end of defun

 

 

 

 

 

;;;------------------------------------------------------------

 

(princ ".")

(defun deferr (s)

(setq ere2 nil)

(setvar "OSMODE" svosmode)

;;; (setvar "CLAYER" svclayer)

(command "_UNDO" "_E")

(if (/= s "Fonction annulee")

(princ (strcat "\nErreur detectee: " s))

)

;;; (setvar "CMDECHO" scmde)

(setq *error* olderr)

(princ)

)

 

;--------------------------------------------------------------------

(princ ".")

(defun getval (code desent)

(cdr (assoc code desent))

)

 

;--------------------------------------------------------------------

(princ ".")

(defun ere_pl1 (ere1 / ere2)

(setq ere2 (list ere1))

(setq ere5 1)

(command "_PLINE" ere1)

(while

(progn

(initget 0 "U Recommencer Arc 1 2")

(setq ere1

(getpoint ere1

"\n1/2/Arc/annUler/Recommencer/: "

)

)

(cond ((null ere1)

(if (> ere5 2)

(command "_C")

(prompt "\nPas assez de segments pour clore !!!")

)

)

((eq ere1 "U")

(cond ((> (length ere2) 1)

(command "_U")

(setq ere2 (cdr ere2))

(If T_arc

(progn

(setq T_arc nil)

(command "_LINE")

)

)

)

(T (prompt "\nPas de segments a annuler !!!"))

)

(setq ere1 (car ere2))

)

((eq ere1 "Recommencer")

(repeat (1- (length ere2))

(command "_U")

)

(command "")

(setq ere2 nil)

)

((eq ere1 "Arc")

(setvar "OSMODE" 1536)

(setq pa1 (getpoint "\n: "))

(initget 0 "1")

(setq pa2 (getpoint "\n1/: "))

(if (= pa2 "1")

(progn

(setvar "OSMODE" 1057)

(setq p1 (getpoint "\n: "))

(setq p2 (getpoint "\n: "))

(setvar "OSMODE" 0)

(setq pix (/ (+ (nth 0 p1) (nth 0 p2)) 2))

(setq piy (/ (+ (nth 1 p1) (nth 1 p2)) 2))

(setq pa2 (list pix piy 0.0))

)

)

(command "_ARC" "_S" pa1 pa2 "_LINE")

(setvar "OSMODE" svosmode)

(setq T_arc T)

(setq ere1 pa2)

(setq ere2 (cons ere1 ere2))

(setq ere5 (1+ ere5))

)

((eq ere1 "1")

(setvar "OSMODE" 1057)

(setq p1 (getpoint "\n: "))

(setq p2 (getpoint "\n: "))

(setvar "OSMODE" 0)

(setq pix (/ (+ (nth 0 p1) (nth 0 p2)) 2))

(setq piy (/ (+ (nth 1 p1) (nth 1 p2)) 2))

(setq ere1 (list pix piy 0.0))

(command ere1)

(setq ere2 (cons ere1 ere2))

(setq ere5 (1+ ere5))

(setvar "OSMODE" svosmode)

)

((eq ere1 "2")

(setvar "OSMODE" 1057)

(setq p1 (getpoint "\n: "))

(setq p2 (getpoint "\n: "))

(setvar "OSMODE" 1057)

(setq p3 (getpoint "\n: "))

(setq p4 (getpoint "\n: "))

(setvar "OSMODE" 0)

(setq pix (/ (+ (nth 0 p1) (nth 0 p2)) 2))

(setq piy (/ (+ (nth 1 p1) (nth 1 p2)) 2))

(setq pint (list pix piy 0.0))

(setq pax (/ (+ (nth 0 p2) (nth 0 p3)) 2))

(setq pay (/ (+ (nth 1 p2) (nth 1 p3)) 2))

(setq pa (list pax pay 0.0))

(setq pbx (/ (+ (nth 0 p1) (nth 0 p4)) 2))

(setq pby (/ (+ (nth 1 p1) (nth 1 p4)) 2))

(setq pb (list pbx pby 0.0))

(setq alpha (angle p1 p2))

(setq alpha (+ (/ pi 2) alpha))

(setq pint1 (polar pint alpha 10))

(setq ere1 (inters pa pb pint pint1 nil))

(command ere1)

(setq ere2 (cons ere1 ere2))

(setq ere5 (1+ ere5))

(setvar "OSMODE" svosmode)

)

(T

(command ere1)

(setq ere2 (cons ere1 ere2))

(setq ere5 (1+ ere5))

)

)

)

)

ere2

)

 

;;;--------------------------------------------------------------------

;;; Command ERE

;;;

(princ ".")

(defun ere ()

(setq olderr *error*

*error* deferr

)

(command "_UNDO" "_G")

(command "_UCS" "")

(setq svosmode (getvar "OSMODE"))

(setvar "OSMODE" 1057)

(prompt "\nDigitalisation de surfaces")

 

(while

(progn

(setq ere3 (entlast)

ere4 (getpoint "\n: ")

)

)

(cond

(T

(setq ere5 (ere_pl1 ere4))

)

)

)

(command "_UCS" "_P")

(command "_UNDO" "_E")

(setq *error* olderr)

 

(princ)

)

 

 

;;;--------------------------------------------------------------------

;;; Routine SOM pour le calcul des surfaces.

;;;

(princ ".")

(defun c:som()

(setq olderr *error*

*error* deferr)

(setq scmde (getvar "CMDECHO"))

(setvar "CMDECHO" 0)

(command "_UNDO" "_G")

(command "_UCS" "")

(setq svosmode (getvar "OSMODE"))

(setvar "OSMODE" 0)

(setq svclayer (getvar "CLAYER"))

(setq val_dcl (load_dialog "SURFACE"))

(setq llist (list "0"))

(tblnext "LAYER" T)

(setq lay (tblnext "LAYER"))

(while (/= lay nil)

(if (/= lay nil)

(progn

(setq nompln (cdr (assoc 2 lay)))

(setq llist (cons nompln llist))

)

)

(setq lay (tblnext "LAYER"))

)

(setq llist (cons "-Tous les plans" llist))

(setq llist (reverse llist))

(if (>= (getvar "maxsort") (length llist))

(setq llist (acad_strlsort llist))

)

(if (not (new_dialog "DDLAYER" val_dcl)) (exit))

(start_list "list_layer")

(mapcar 'add_list llist)

(end_list)

(set_tile "list_layer" "0")

(action_tile "cancel" "(done_dialog) (setq deferr \"\") (exit)")

(action_tile "accept"

(strcat "(progn (setq chx_lay (get_tile \"list_layer\"))"

"(done_dialog))"

)

)

(start_dialog)

(if chx_lay

(progn

(setq cchx_lay (nth (atoi chx_lay) llist))

(if (= cchx_lay "-Tous les plans")

(setq js (ssget))

(setq js (ssget "X" (list (cons 8 cchx_lay))))

)

)

)

(if js

(progn

(setq i 0)

(setq surft 0.0)

(setq nb (sslength js))

(while (< i nb)

(progn

(setq ent (ssname js i))

(setq ent (entget ent))

(setq tent (cdr (assoc 0 ent)))

(if (= tent "TEXT")

(progn

(setq surfac (cdr (assoc 1 ent)))

(setq surfac (substr surfac 1 (- (strlen surfac) 3)))

(setq surfac (atof surfac))

(setq surft (+ surfac surft))

)

)

(setq i (1+ i))

)

)

(if (not (new_dialog "RESULTAT" val_dcl)) (exit))

 

(if (= cchx_lay "-Tous les plans")

(set_tile "SOMME" (strcat "La somme des surfaces de tous les calques est de "(rtos surft 2 (getvar "LUPREC")) " m2."))

(set_tile "SOMME" (strcat "La somme des surfaces du claque " cchx_lay " est de "(rtos surft 2 (getvar "LUPREC")) " m2."))

)

(action_tile "accept" "(done_dialog)")

(start_dialog)

)

)

(command "_UCS" "_P")

(setvar "OSMODE" svosmode)

(setvar "CLAYER" svclayer)

(command "_UNDO" "_E")

(setq *error* olderr)

(setvar "CMDECHO" scmde)

(princ)

)

 

;--------------------------------------------------------------------

(princ ".")

 

 

Merci par avance!