Longueur cumulée en fonction du calque et du type de ligne

jujugeometre · le 5 janvier 2022

Bonjour,

Je souhaite écrire dans mon dessin la longueur cumulée de lignes, polylignes et arcs en fonction du calque et du type de ligne (je peux avoir dans le meme calque des types de ligne différents). J'avais trouvé plusieurs TOPIC avec des sommes de longueur mais pas en faisant ce tri.

pour la logique d'écriture :

- je crée un jeu de sélection,

- je le parcours en recherchant les éléments identiques et en les supprimant au fur et à mesure,

- à chaque boucle j'écris une ligne de résultat

(defun c:ztest ( /	;*error* OLDERROR myerr
			OLDATTDIA OLDCLAYER OLDOSMODE OLDATTREQ OLDCMLEADERSTYLE OLDCOTEXT OLDLUPREC
			i k j pt1 pt2 selline selzone selbloc longtotale entilong entjlong entilayer entjlayer entitypelin entjtypelin
			)

(vl-load-com)
;sauvegarde des paramètres du dessin
(setq	OLDATTDIA	(getvar	"attdia")
	OLDCLAYER	(getvar	"clayer")
	OLDCOTEXT	(getvar	"DIMSTYLE")
	OLDOSMODE	(getvar	"OSMODE")
	OLDATTREQ	(getvar	"ATTREQ")
	;OLDERROR	*error*
	;*error*		myerr
	OLDCMLEADERSTYLE	(getvar "cmleaderstyle")
	OLDLUPREC	(getvar "LUPREC")
	OLDAUPREC	(getvar "AUPREC")
      	)

;initialise les nouveaux paramètres
(setvar 	"osmode"	0)
(setvar 	"attdia"	0)
(setvar 	"attreq"	1)
(setvar 	"cmdecho"	0)
(setvar 	"filedia"	0)
(setvar 	"pickfirst"	1)
(setvar		"luprec"	3)
(setvar		"auprec"	6)

(command-s "_-LAYER" "L" "0" "CH" "0" "" ) ;choisir 0 comme calque courant

;affecter à sel la selection des objets à lister  
(setq	pt1	(getpoint "\n point bas gauche")
	pt2	(getcorner pt1 "\n point haut droit")
	)

(setq	selline	(ssget "_C" pt1 pt2 (list '(-4 . "<OR")  '(0 . "LWPOLYLINE") '(0 . "ARC") '(0 . "LINE") '(0 . "MLINE")  '(-4 . "OR>") ) )
	);setq


;|
on va faire la liste des lignes avec le code DXF 8 c'est le calque, on peut faire une sélection sur les 3 premiers caractères pour regrouper
par réseau et ensuite avec le type de ligne c'est le code DXF 6
c'est la variable LENGTH dans les proprietés qui permet d'obtenir la longueur
|;
(setq i 0 ;incrément de parcours du jeu de sélection
      j 1 ;incrément pour parcourir la liste à la recherche d'éléments dans le meme calque avec le meme type de ligne
      k 0 ;increment pour le trace du tableau
      longtotale 0 ;je mets à 0 la longueur du total
      pt1 (getpoint "\nPoint haut gauche d'insertion : ") ;point d'insertion du coin haut gauche du tableau
      );setq
  
(command-s "_-LAYER" "L" "WLE-01,ZZZ" "CH" "WLE-01" "" );choisir en calque courant WLE-01 qui servira à insérer les donnees
  
(while (ssname selline i)
  (setq enti (ssname selline  i)
	entil (entget enti)
	entilayer (cdr (assoc 8 entil))
	entilong (getpropertyvalue enti "LENGTH")
	longtotale (+ longtotale entilong) ;je somme les longueurs
	);setq
  (cond
    ( (/= (cdr (assoc 6 entil) ) nil ) (setq entitypelin (cdr (assoc 6 entil) ) ) )
    ( T (setq entitypelin "DC") ) );cette condition vérifie si on a une valeur dans le type de ligne différente de DUCALQUE sinon elle affecte DC

  ;il faut que je crée ensuite une seconde boucle qui va rechercher les éléments avec le meme type et calque dans la suite de la liste
  (while  (ssname selline j )
	  (setq entj	(ssname selline j )
		entjl 	(entget entj)
		entjlayer	(cdr (assoc 8 entjl))
		entjlong 	(getpropertyvalue entj "LENGTH") )
	  (cond ;cette condition vérifie si on a une valeur dans le type de ligne différente de DUCALQUE sinon elle affecte DC
    		( (/= (cdr (assoc 6 entjl) ) nil ) (setq entjtypelin (cdr (assoc 6 entjl) ) ) )
    		( T (setq entjtypelin "DC") ) )
    
	  (if 	(and (wcmatch entilayer entjlayer) (wcmatch entitypelin entjtypelin) ) 	;je verifie si le calque et le type de ligne sont les memes
		(progn
	    	(setq	longtotale 	(+ longtotale entjlong)		;je somme les longueurs
			selline		(ssdel entj selline)	)	;je supprime ensuite l'élément du jeu de sélection
		)		
	    );if
	(setq j (1+ j) )
    );seconde boucle while

;il faut que je trace le tableau ensuite qui reprend les infos de chaque ligne
	(command-s	"-TEXTE" "J" "MG" (list (+ (car pt1) 0.50 ) ( - (cadr pt1) (* 1.50 k) ) ) 1 100   (strcat entilayer ) ) 	;calque
	(command-s	"-TEXTE" "J" "MG" (list (+ (car pt1) 10.00 ) ( - (cadr pt1) (* 1.50 k) ) ) 1 100  (strcat entitypelin ) ) 	;type de ligne
	(command-s	"-TEXTE" "J" "MG" (list (+ (car pt1) 20.00 ) ( - (cadr pt1) (* 1.50 k) ) ) 1 100  (rtos longtotale 2 2 )  ) 	;longueur totale

  (setq i (1+ i)	;incrément de l'indice de la liste
	k (1+ k)
	longtotale 0 ) 	;je remets la longueur totale à 0
  (setq j (1+ i))	;remise à zéro de l'incrément de recherche de la seconde liste
);while




  
;restaurer les paramètres initiaux
(command-s	"_-DIMSTYLE"		"R"	OLDCOTEXT	)
(command-s	"_-LAYER"	"L"	OLDCLAYER	"CH"	OLDCLAYER	"")
(setvar 	"attdia"	OLDATTDIA)
(setvar		"attreq"	OLDATTREQ)
(setvar		"OSMODE"	OLDOSMODE)
(setq 		*error* 	OLDERROR)
(setvar		"cmleaderstyle" OLDCMLEADERSTYLE)
(setvar		"luprec"	OLDLUPREC)
(setvar		"auprec"	OLDAUPREC)



);defun
(princ)

ça ne marche pas au niveau de la réduction de la liste (ssdel...) il écrit plusieurs lignes de résultat avec meme calque et meme type de ligne, je ne comprends pas d'ou cela vient.

si quelqu'un voit le souci de construction ou a une autre proposition de construction, je précise que je ne connais pas le VLISP.

j'en profite pour souhaiter à tous une bonne année.

Bien à vous

Luna · le 6 janvier 2022

Coucou,

Premièrement tu peux simplifier ton filtre ssget

(list '(-4 . "<OR")  '(0 . "LWPOLYLINE") '(0 . "ARC") '(0 . "LINE") '(0 . "MLINE")  '(-4 . "OR>") ) )

a une liste plus simple

'((0 . "LWPOLYLINE,ARC,LINE,MLINE))

Ensuite, lorsqu'on supprime des entités d'un jeu de sélection, on préfère parcourir le jeu de sélection en partant de la fin et non du début. Cela permet d'éviter les erreurs du genre l'entité à l'indice i est supprimée donc l'entité i+1 devient l'entité à l'indice i, mais dans ta boucle tu passeras à l'indice i+1 (donc cela correspond à l'entité i+2 avant la suppression). Pour cela on favorise une écriture du genre

(repeat (setq i (sslength selline))
  (setq enti (ssname selline (setq i (1- i))))
  ...

Je pense que la seconde boucle (while) est en trop. Il faut plutôt que tu arrives à comprendre le principe des listes, et plus précisément des listes d'association. On construit une liste avec les fonctions (list), (append) et/ou (cons). Le plus courant c'est la fonction (cons) dans une boucle, comme par exemple

(while ...
  (setq lst (cons value lst))
)

Où 'value' correspond à la valeur que l'on veut ajouter à la liste. Cela va construire une liste basique, en revanche une liste d'association c'est plutôt quelque chose que l'on va construire comme ceci :

(while ...
  (setq lst (cons (cons key value) lst))
)

Ici 'key' correspond à la clé de recherche, donc pour toi il pourrait s'agir du nom du calque ou du type de ligne et 'value' correspond à la valeur que l'on souhaite associer à la clé. Par exemple une liste

(0 1 2 3 4 5 6 7 8 9)

correspond à la première version, il s'agit d'une liste normale. Par contre un exemple de liste d'association c'est le résultat de (entget)

(
  (-1 . <Nom d'entité: 26841854c60>)
  (0 . "INSERT")
  (5 . "7F6")
  (102 . "{ACAD_XDICTIONARY")
  (360 . <Nom d'entité: 26841854ce0>)
  (102 . "}")
  (330 . <Nom d'entité: 268420f11f0>)
  (100 . "AcDbEntity")
  (67 . 0)
  (410 . "Model")
  (8 . "0")
  (100 . "AcDbBlockReference")
  (2 . "Flower")
  (10 0.0 0.0 0.0)
  (41 . 1.0)
  (42 . 1.0)
  (43 . 1.0)
  (50 . 0.0)
  (70 . 0)
  (71 . 0)
  (44 . 0.0)
  (45 . 0.0)
  (210 0.0 0.0 1.0)
)

Avec une liste d'association on peut très facilement récupérer une valeur 'value' associée à une clé en recherchant justement la clé. Tu dois récupérer le nom du calque de l'objet ? Et bien tu fais

(cdr (assoc 8 (entget enti)))

Donc pour faire le tri dont tu parles, il te faut utiliser ce principe en créant une liste d'association de deux niveaux ! Le premier niveau sera une liste d'association dont les clés de recherche correspondent au nom des calques, et leur valeur correspondra à une liste d'association dont les clés de recherche correspondent au nom du type de lignes et leur valeur correspondra à la longueur correspondante (= la longueur cumulée des objets possédant un calque identique et un type de ligne identique). Voici un exemple de programme qui pourrait répondre à ta demande :

(defun c:LONGTOT (/ make-list jsel i name lst lng lay ltp)
  (defun make-list (lst layer ltype long / ltlst)
    (if (setq ltlst (assoc layer lst))
      (subst
        (cons
          layer
          (if (assoc ltype (cdr ltlst))
            (subst
              (cons ltype (+ long (cdr (assoc ltype (cdr ltlst)))))
              (assoc ltype (cdr ltlst))
              (cdr ltlst)
            )
            (append (cdr ltlst) (list (cons ltype long)))
          )
        )
        ltlst
        lst
      )
      (append lst (list (cons layer (list (cons ltype long)))))
    )
  )
  (if (setq jsel (ssget '((0 . "*LINE,ARC"))))
    (progn
      (repeat (setq i (sslength jsel))
        (setq
          name (ssname jsel (setq i (1- i)))
          lng (getpropertyvalue name "LENGTH")
          lay (cdr (assoc 8 (entget name)))
          ltp (if (assoc 6 (entget name)) (cdr (assoc 6 (entget name))) "ByLayer")
          lst (make-list lst lay ltp lng)
        )
      )
      (mapcar
        '(lambda (x / lay ltp lng)
          (princ
            (strcat
              "\nLongueur du calque \""
              (setq lay (car x))
              "\" = "
              (rtos (apply '+ (mapcar 'cdr (cdr x))) 2 2)
              (apply
                'strcat
                (mapcar
                  '(lambda (l)
                    (strcat
                      "\n - "
                      (car l)
                      " = "
                      (rtos (cdr l) 2 2)
                    )
                   )
                  (vl-sort (cdr x) '(lambda (e1 e2) (< (car e1) (car e2))))
                )
              )
            )
          )
         )
        (vl-sort lst '(lambda (e1 e2) (< (car e1) (car e2))))
      )
    )
  )
  (princ)
)

Tu peux simplement t'en inspirer, l'utiliser, l'adapter, etc... Il me sort un résultat de ce style-là par exemple :

Longueur du calque "Calque1" = 328.29
 - ByBlock = 46.61
 - ByLayer = 25.69
 - Continuous = 228.38
 - DASHED = 27.62
Longueur du calque "Calque2" = 108.92
 - ByLayer = 58.20
 - DASHED = 50.72
Longueur du calque "Calque3" = 186.88
 - ByLayer = 99.01
 - Continuous = 87.87
Longueur du calque "Calque4" = 102.75
 - ByLayer = 102.75
Longueur du calque "Calque5" = 217.55
 - ByLayer = 146.46
 - Continuous = 71.09
Longueur du calque "Calque6" = 87.67
 - ByLayer = 45.55
 - DASHED = 42.12
Longueur du calque "Calque8" = 327.99
 - ByBlock = 103.88
 - ByLayer = 157.14
 - Continuous = 35.83
 - DASHED = 31.13

Bisous,
Luna

lecrabe · le 6 janvier 2022

Hello @Luna

1) Merci pour cette excellente routine que j'ai renommee "Length_Tot_per_LineType" !

2) SVP quelle serait la "meme" version pour les Epaisseurs de traits ?

Meilleurs Voeux, La Sante, Bye, lecrabe

Luna · le 6 janvier 2022

Coucou @lecrabe,

Etrangement j'ai senti venir une adaptation de la commande 😉

Du coup j'essaye d'adapter le fonctionnement de (make-list) pour pouvoir gérer n niveaux d'association et pouvoir adapter la commande à autant de propriétés que l'on souhaite dans l'ordre qu'on veut (une commande gérée par une liste principale, cf. >>ce sujet<< en clair).

Pour l'instant je manque un peu de temps mais je verrais chat dans le we sûrement. Cela devrait pouvoir répondre à ton besoin (quel qu’il soit ^^").

Mais sinon dans l'immédiat, il suffit de remplacer le code DXF 6 par le code DXF 370 ici :

ltp (if (assoc 6 (entget name)) (cdr (assoc 6 (entget name))) "ByLayer")

Bisous,
Luna

Modifié le 6 janvier 2022 par Luna

lecrabe · le 6 janvier 2022

Hello @Luna

Merci par contre pour les couleurs "Non Classiques" autres que 0-256, ce sera un traitement spécifique car multiples codes DXF (RGB, RAL, Pantone, etc)

Bye, lecrabe

Luna · le 6 janvier 2022

En effet, seul les couleurs sont définies par les codes 62, 420 et 430 mais cela ne pose pas vraiment soucis car le sujet se posera en amont de la fonction d'association. Donc il faudra simplement que je définisse une liste qui puisse prendre en compte ce genre de subtilité pour prendre la valeur du code 430 si existant, sinon 420 si existant puis 62 si existant sinon "DuCalque". Mais chat devrait pouvoir se faire via une liste (apply) sur un (lambda) pour le choix des valeurs de clés.

Avec la fonction (GetAnyProperty), cela me permettra de fonctionner aussi bien avec les propriétés DXF, ActiveX ou Visual normalement. Bref, je vais décortiquer un peu tout chat ce we en espérant d'avoir une solution clean et je reviendrais vers vous si tout se passe bien ! Cela me permettra de travailler un peu les fonctions récurrentes qui plus est donc c'est tout bénef' pour moi 🙂

Bisous,
Luna

lecrabe · le 6 janvier 2022

Hello @Luna

Merci tu es un Chou !

Bye, lecrabe

bonuscad · le 6 janvier 2022

Bonjour,

Un début de code qui fera le cumul des longueurs, pour les polylignes les segments droit ou arrondis sont dissociés en ligne et arc.

Copier-coller le code directement en ligne de commande pour faire un test

((lambda ( / js n ename obj dxf_ent lay tl l_tl l_lay pr lg_arc lg_line dist_start dist_ent pt_start pt_end seg_len bulge cumul_line cumul_arc nw_list_l nw_list_a)
  (vl-load-com)
  (princ "\nSélectionnez des objets POLYLIGNE, LIGNE, ARC, CERCLE")
  (setq js
    (ssget
      (list
        '(0 . "*POLYLINE,LINE,ARC,CIRCLE")
        (cons 67 (if (eq (getvar "CVPORT") 1) 1 0))
        (cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model"))
        '(-4 . "<NOT")
          '(-4 . "&")
          '(70 . 112)
        '(-4 . "NOT>")
      )
    )
  )
  (cond
    (js
      (repeat (setq n (sslength js))
        (setq
          ename (ssname js (setq n (1- n)))
          obj (vlax-ename->vla-object ename)
          dxf_ent (entget ename)
          lay (cdr (assoc 8 dxf_ent))
          tl (cdr (assoc 6 dxf_ent))
        )
        (if (null tl) (setq tl (cdr (assoc 6 (tblsearch "LAYER" lay)))))
        (if (not (member tl l_tl)) (setq l_tl (cons tl l_tl)))
        (if (not (member lay l_lay)) (setq l_lay (cons lay l_lay)))
        (cond
          ((wcmatch (cdr (assoc 0 dxf_ent)) "*POLYLINE")
            (setq
              pr -1
              lg_arc 0.0
              lg_line 0.0
            )
            (repeat (fix (vlax-curve-getEndParam obj))
              (setq
                dist_start (vlax-curve-GetDistAtParam obj (setq pr (1+ pr)))
                dist_end (vlax-curve-GetDistAtParam obj (1+ pr))
                pt_start (vlax-curve-GetPointAtParam obj pr)
                pt_end (vlax-curve-GetPointAtParam obj (1+ pr))
                seg_len (- dist_end dist_start)
                bulge (if (equal seg_len (distance pt_start pt_end) 1E-06) 0 1)
              )
              (if (zerop bulge)
                (setq lg_line (+ lg_line seg_len))
                (setq lg_arc (+ lg_arc seg_len))
              )
            )
            (setq
              cumul_line (cons (cons (cons lay tl) lg_line) cumul_line)
              cumul_arc (cons (cons (cons lay tl) lg_arc) cumul_arc)
            )
          )
          (T
            (cond
              ((eq (vla-get-ObjectName obj) "AcDbArc")
                (setq cumul_arc (cons (cons (cons lay tl) (vlax-get-property obj "ArcLength")) cumul_arc))
              )
              ((eq (vla-get-ObjectName obj) "AcDbCircle")
                (setq cumul_arc (cons (cons (cons lay tl) (vlax-get-property obj "Circumference")) cumul_arc))
              )
              (T
                (setq cumul_line (cons (cons (cons lay tl) (vlax-get-property obj "Length")) cumul_line))
              )
            )
          )
        )
      )
      (foreach i l_lay
        (foreach k l_tl
          (setq l_sort (vl-remove-if-not '(lambda (x) (equal (car x) (cons i k))) cumul_line))
          (if l_sort
            (setq nw_list_l (cons (list (caar l_sort) (apply '+ (mapcar 'cdr l_sort))) nw_list_l))
          )
          (setq l_sort (vl-remove-if-not '(lambda (x) (equal (car x) (cons i k))) cumul_arc))
          (if l_sort
            (setq nw_list_a (cons (list (caar l_sort) (apply '+ (mapcar 'cdr l_sort))) nw_list_a))
          )
        )
      )
;A PARTIR D'ICI ON EXPLOITE LES VARIABLES "nw_list_l" et "nw_list_a" COMME ON VEUT(un tableau, du texte, un fichier...)
;nw_list_l pour les LIGNES
;new_list_a pour les ARCS
; pour chaque élément de la liste
; le CAR de la liste donne la paire pointée Calque et Type de ligne.
; le CDR donne la somme des éléments
      (print nw_list_l)(print nw_list_a)
    )
  )
  (prin1)
))

Après comme dit dans le code on exploite le résultat comme on le désire...

Luna · le 7 janvier 2022

Coucou,

Bon j'obtiens un résultat mais certainement pas celui que je désire...
Ci-dessous les fonctions (make-a-list-properties) et (loop-a-list-properties) qui sont fonctionnelles (du moins elles ne me font pas défaut dans les limites d'utilisation que j'ai testé) :

;                                   []-----------------------[] make-a-list-properties []-----------------------[]                                  ;
;--- Date of creation       > 06/01/2022                                                                                                            ;
;--- Last modification date > 06/01/2022                                                                                                            ;
;--- Author                 > Luna                                                                                                                  ;
;--- Version                > 1.0.0                                                                                                                 ;
;--- Class                  > "BaLst"                                                                                                               ;

;--- Goal and utility of the main function                                                                                                          ;
;   When used in a loop function and by defining the 'lst' variable with the result of this function, it creates an association list with different ;
;   levels. The main idea is to set value (like a counter, the object's length, etc.) and creates a new list of keys if not existant or applies a   ;
;   function (like '+, '-, 'strcat) between the old and the new value with the same list of keys. For that, it will considered for each key a new   ;
;   level of association list. In fine, each similar objects by the value of their properties name, will be match together.                         ;
;                                                                                                                                                   ;
;--- Declaration of the arguments                                                                                                                   ;
; The function (make-a-list-properties) have 4 argument(s) :                                                                                        ;
;   --•  lst                    > corresponds to the existing list you want to build withing a loop. The common use will be, for example, see below ;
;                               (setq lst (make-a-list-properties lst ...))                                                                         ;
;     (type lst) = 'LST                         | Ex. : a variable name to build the list within a loop                                             ;
;   --•  k-lst                  > corresponds to the list of property value that will be used to determine the number of level of association list. ;
;                               Each property value will be used as the key for each association list.                                              ;
;     (type k-lst) = 'LST                       | Ex. : '("Layer1" "LWPOLYLINE"), '("BlockName2" "63,115,69" "23.42"), '("Layer0"), ...             ;
;   --•  value                  > corresponds to the new value for the list of keys. If the 'lst' already contain a value for that list of keys, it ;
;                               will be add to the old one (depending of 'fun' value), otherwise it will be add to the list with the list of keys   ;
;     (type value) = '...                       | Ex. : 1 (to count the entity units), (getpropertyvalue name "LENGTH"), "63,115,69", ...           ;
;   --•  fun                    > corresponds to the function that will be used to connect the old value with the new one. The most common value of ;
;                               'fun' is '+, to add the new value with the old one                                                                  ;
;     (type fun) = 'SYM                         | Ex. : '+, '-, 'strcat, ...                                                                        ;
;                                                                                                                                                   ;
;--- Return                                                                                                                                         ;
;   The function (make-a-list-properties) returns the new value of the list, with the new value substitute to the old one if existing, or add it to ;
;   the list.                                                                                                                                       ;
;     Ex. : (make-a-list-properties lst (list Layer ObjectName) 1 '+) returns after the loop from a selection set                                   ;
;             ( ("Layer1" ("LWPOLYLINE" . 13) ("CIRCLE" . 4) ("INSERT" . 1))                                                                        ;
;               ("Layer3" ("CIRCLE" . 1) ("LINE" . 14) ("LWPOLYLINE" . 42))                                                                         ;
;               ("Layer2" ("INSERT" . 69))                                                                                                          ;
;               ("Layer9" ("LINE" . 3) ("ARC" . 11))                                                                                                ;
;             )                                                                                                                                     ;
;                                                                                                                                                   ;
;--- Historic list of the version with their modification status                                                                                    ;
; +------------+----------------------------------------------------------------------------------------------------------------------------------+ ;
; |   v1.0.0   |   Creation of the function                                                                                                       | ;
; +------------+----------------------------------------------------------------------------------------------------------------------------------+ ;
;                                                                                                                                                   ;

(defun make-a-list-properties (lst k-lst value fun / key search)
  (if (null (cdr k-lst))
    (if (setq search (assoc (setq key (car k-lst)) lst))
      (subst (cons key (apply fun (list (cdr search) value))) search lst)
      (append lst (list (cons key value)))
    )
    (if (setq search (assoc (setq key (car k-lst)) lst))
      (subst (cons key (make-a-list-properties (cdr search) (cdr k-lst) value fun)) search lst)
      (append lst (list (cons key (make-a-list-properties (cdr search) (cdr k-lst) value fun))))
    )
  )
)

;                                   []-----------------------[] loop-a-list-properties []-----------------------[]                                  ;
;--- Date of creation       > 07/01/2022                                                                                                            ;
;--- Last modification date > 07/01/2022                                                                                                            ;
;--- Author                 > Luna                                                                                                                  ;
;--- Version                > 1.0.0                                                                                                                 ;
;--- Class                  > "BaLst"                                                                                                               ;

;--- Goal and utility of the main function                                                                                                          ;
;   To facilitate the automatic creation of a list of associations of different levels via (make-a-list-properties) from a selection set.           ;
;                                                                                                                                                   ;
;--- Declaration of the arguments                                                                                                                   ;
; The function (loop-a-list-properties) have 4 argument(s) :                                                                                        ;
;   --•  jsel                   > is the selection set used to create the (make-a-list-properties)                                                  ;
;     (type jsel) = 'PICKSET                    | Ex. : (ssget), ...                                                                                ;
;   --•  PropertyList           > corresponds to the list of property name that will be used to determine the number of level of association list.  ;
;                               Each property name will inquire the property value of the objects with (GetAnyProperty) function                    ;
;     (type PropertyList) = 'LST                | Ex. : '(8 'ObjectName "COLOR"), '("LineTypeScale" 0), ...                                         ;
;   --•  value                  > corresponds to the new value for the list of keys. If the 'lst' already contain a value for that list of keys, it ;
;                               will be add to the old one (depending of 'fun' value), otherwise it will be add to the list with the list of keys   ;
;     (type value) = '...                       | Ex. : 1 (to count the entity units), (quote (getpropertyvalue name "LENGTH")), ...                ;
;   --•  fun                    > corresponds to the function that will be used to connect the old value with the new one. The most common value of ;
;                               'fun' is '+, to add the new value with the old one                                                                  ;
;     (type fun) = 'SYM                         | Ex. : '+, '-, 'strcat, ...                                                                        ;
;                                                                                                                                                   ;
;--- List of dependent's functions                                                                                                                  ;
;   --•  "BaLst" ---> make-a-list-properties                        | v1.0.0 - 06/01/2022 (Luna)                                                    ;
;   --•  "DtObj" ---> GetAnyProperty                                | v1.0.0 - 30/12/2021 (Luna)                                                    ;
;                                                                                                                                                   ;
;--- Return                                                                                                                                         ;
;   The function (loop-a-list-properties) returns the association list after the loop for each object in the selection set.                         ; 
;     Ex. : (loop-a-list-properties (ssget) (list 8 0) 1 '+) returns                                                                                ;
;             ( ("Layer1" ("LWPOLYLINE" . 13) ("CIRCLE" . 4) ("INSERT" . 1))                                                                        ;
;               ("Layer3" ("CIRCLE" . 1) ("LINE" . 14) ("LWPOLYLINE" . 42))                                                                         ;
;               ("Layer2" ("INSERT" . 69))                                                                                                          ;
;               ("Layer9" ("LINE" . 3) ("ARC" . 11))                                                                                                ;
;             )                                                                                                                                     ;
;                                                                                                                                                   ;
;--- Historic list of the version with their modification status                                                                                    ;
; +------------+----------------------------------------------------------------------------------------------------------------------------------+ ;
; |   v1.0.0   |   Creation of the function                                                                                                       | ;
; +------------+----------------------------------------------------------------------------------------------------------------------------------+ ;
;                                                                                                                                                   ;

(defun loop-a-list-properties (jsel PropertyList value fun / i name lst)
  (if jsel
    (repeat (setq i (sslength jsel))
      (setq
        name (ssname jsel (setq i (1- i)))
        lst
          (make-a-list-properties
            lst
            (mapcar
              '(lambda (pp / ppType)
                (setq ppType (type pp))
                (cdr
                  (GetAnyProperty
                    name
                    "*"
                    (cond ((= ppType 'INT) 0) ((= ppType 'STR) 1) ((= ppType 'SYM) 2))
                    pp
                  )
                )
               )
              PropertyList
            )
            (eval value)
            fun
          )
      )
    )
  )
)

Par contre ma maîtrise des fonctions récurrente ne me permet pas de d'imprimer sur la même ligne les propriétés amonts avec la somme des propriétés avals...
Ci-dessous la version semi-fonctionnelle (le total n'est pas imprimé sur la ligne désirée...mais chat marche...à moitié) :

(defun princ-a-list-properties (lst msg p-lst fun / r p s u c)
  (setq
    r (car p-lst)
    p (car r)
    s (cadr r)
    u (caddr r)
    c (cadddr r)
  )
  (if msg (princ msg))
  (mapcar
    '(lambda (l / k v)
      (setq
        k (car l)
        v (cdr l)
      )
      (princ
        (strcat
          (cond (p) (""))
          (vl-princ-to-string k)
          (cond (s) (""))
        )
      )
      (princ
        (strcat
          (vl-princ-to-string
            (if (null (cdr p-lst))
              v
              (setq v (apply c (princ-a-list-properties v nil (cdr p-lst) fun)))
            )
          )
          (cond (u) (""))
        )
      )
      v
     )
    (if fun
      (vl-sort lst '(lambda (kp1 kp2) ((eval fun) (car kp1) (car kp2))))
      lst
    )
  )
)

Le soucis c'est que je (princ) au fur et à mesure que le programme avance donc au final, les sommes cumulées ne seront imprimées qu'à la toute fin...
Ci-dessous la commande SCP qui consiste uniquement à laisser l'utilisateur définir ses filtres comme il le souhaite (donc le premier (setq ...) est un exemple d'utilisation parmi tant d'autres) :

(defun c:SCP (/ m-lst value msg fun v-fun filter)
  (setq
    m-lst
      (list
        (cons 8 (list "\nLayer name : \"" "\" :" "u" '+))
        (cons 'ObjectName (list "\n  - ObjectName <" "> :" nil '+))
        (cons "COLOR" (list "\n   > Color " " : " "u" '+))
      )
    value   1
    msg     ""
    fun     '+
    v-fun   '<
    filter  (list '((0 . "*POLYLINE,LINE,ARC,CIRCLE")))
  )
  (setq lst (loop-a-list-properties (apply 'ssget filter) (mapcar 'car m-lst) value fun))
  (princ-a-list-properties
    lst
    msg
    (mapcar 'cdr m-lst)
    v-fun
  )
  (princ)
)

Le problème du retour ci-dessous :

For layer "0" :
  - ObjectName <AcDbPolyline> :
   > Color 2 : 1u
   > Color 256 : 1u
   > Color 62,193,123 : 1u
   > Color DIC COLOR GUIDE(R),DIC 634 : 1u44u

Le "44u" situé à la toute fin est en réalité "4" qui doit être affiché comme le total de <AcDbPolyline> et "4u" qui doit être affiché comme le total de 'For layer "0" :'.

Donc j'ai essayé de prendre le problème à l'envers : utiliser la fonction (princ-a-list-properties) pour regrouper tout le beau monde sous forme de liste de chaînes de caractères et imprimer le résultat avec (princ (apply 'strcat (princ-a-list-properties))) mais pour le moment je commence à me perdre dans la logique des récurrences de fonctions pour construire une liste cohérente (et surtout réussir à conserver ce fichu total à chaque remontée !!!!). Bref j'en ai pas encore terminé mais je ne compte pas abandonner xD

Au moins le fonctionnement de SCP me semble relativement simple (une fois qu'il y aura des commentaires chat le sera encore plus !) pour quiconque fait un peu d'AutoLISP.

Bisous,
Luna

jujugeometre · le 7 janvier 2022

@Luna Bonsoir et merci pour ton aide extrêmement complète, c'est exactement comme ça a chaque fois que j'ai une idée de développement, j'imagine un truc simple et concis comme tu le fais et je me retrouve avec un truc brouillon et qui marche moyennement ou pas du tout comme le mien, c'est rageant.

Je ne désespère pas, avec le temps peut être...

encore merci pour ta réponse, je voulais intégrer le calcul de longueur à une fonction globale avec le décompte des blocs et des surfaces de hachures et du coup tu as devancé cela avec ton dev, c'est top.

jujugeometre · le 12 janvier 2022

Bonsoir, j'ai poursuivi sur ce projet pour faire un décompte de blocs en fonction de leur calque et de leur caractérisation que je mentionne dans un attribut OBS1 dans mes dessins. Du coup je me suis fortement inspiré de ta proposition @Luna dont je te remercie pour créer une liste de paires pointées et ainsi aller chercher dans les paires les infos.

j'ai toujours un chiffre qui sort à la fin, un 4 dont je n'arrive pas à me débarasser, j'ai vu que tu avais aussi ce pb, est ce que tu sais d'ou cela vient?

;|
je veux faire un listing de lignes, des zones et de blocs
pour obtenir les longueurs cumulées, le nombre d'objet et 
|;

(defun c:ztest ( /	;*error* OLDERROR myerr
			OLDATTDIA OLDCLAYER OLDOSMODE OLDATTREQ OLDCMLEADERSTYLE OLDCOTEXT OLDLUPREC
			;i k j pt1 pt2 selline selzone selbloc longtotale entilong entjlong entilayer entjlayer entitypelin entjtypelin
			)

(vl-load-com)
  
;sauvegarde des paramètres du dessin
(setq	OLDATTDIA	(getvar	"attdia")
	OLDCLAYER	(getvar	"clayer")
	OLDCOTEXT	(getvar	"DIMSTYLE")
	OLDOSMODE	(getvar	"OSMODE")
	OLDATTREQ	(getvar	"ATTREQ")
	;OLDERROR	*error*
	;*error*		myerr
	OLDCMLEADERSTYLE	(getvar "cmleaderstyle")
	OLDLUPREC	(getvar "LUPREC")
	OLDAUPREC	(getvar "AUPREC")
)

;initialise les nouveaux paramètres
(setvar 	"osmode"	0)
(setvar 	"attdia"	0)
(setvar 	"attreq"	1)
(setvar 	"cmdecho"	0)
(setvar 	"filedia"	0)
(setvar 	"pickfirst"	1)
(setvar		"luprec"	3)
(setvar		"auprec"	6)

(command-s "_-LAYER" "L" "0" "CH" "0" "" ) ;choisir 0 comme calque courant

;selectonner une fenetre des objets à travailler  
(setq	  pt1	(getpoint "\n point bas gauche")
	  pt2	(getcorner pt1 "\n point haut droit")
)

;construire les jeux de sélection des blocs, des lignes et des hachures
(setq	selline	(ssget "_C" pt1 pt2 '((0 . "*LINE,ARC") ) )
	
	selbloc	(ssget "_C" pt1 pt2 '((0 . "INSERT") ) )
);setq

;--------------------------- LIGNES  / POLYLIGNES / ARCS --------------------------------------------------------------------------------------------------------------
(if 	(/= selline nil)  ;je vérifie que selline n'est pas vide
	(LONGTOT selline) ;on utilise la fonciton LONGTOT sur la sélection
(princ "\n pas de ligne à lister \n")
);if

;--------------------------- BLOCS  / SYMBOLES PONCTUELS--------------------------------------------------------------------------------------------------------------
(if (/= selbloc nil) ;je vérifie que selbloc n'est pas vide
  (progn
  (setq listunit '() );on remet listunit à vide
  
 ;je veux construire une liste qui sera ( " lay  nat " . nombre ) que j'incrémenterai à chaque tour si je retrouve la paire pointée dans la liste générale

  (repeat (setq i (sslength selbloc) )
          (setq name (ssname selbloc (setq i (1- i)))
          	lst (getattributevalues name)     ;je récupère les valeurs du champ OBS1 de l'attribut du bloc avec la fonction de LEE MAC
	        nat (if (cdr (assoc "OBS1" lst))  (cdr (assoc "OBS1" lst))  (cdr (assoc 2 (entget name))) )   ;je cherche la valeur qui est dans l'attribut OBS1 du bloc si il n'y en a pas, je le remplace par le nom du bloc
   		lay (cdr (assoc 8 (entget name))) ;je sors le calque
 ; puis je ressors pour chaque paire la valeur avec le calque et la valeur de OBS1 qui est la nature de l'objet
		entl (strcat lay " " nat )        ;construire la référence CALQUE NATURE
		);setq

   	   (if 	(setq entpp (assoc entl listunit) )	; je recherche si la paire pointée existe dans listunit et je l'affect à ENTPP
		(setq listunit
		  (subst
			(cons (car entpp) (1+ (cdr entpp)))
		    	entpp
		    	listunit
		  );subst
		 );setq
		(setq listunit (cons (cons entl 1) listunit  )) ;si il n'existe pas encore je lui affecte une valeur de 1
	     );if
  );repeat

(mapcar '(lambda (x) (princ (strcat "\n Calque ou Nom de bloc de l'objet = " (car x) " nombre objets = " (itoa (cdr x) ) ) ) ) listunit) ;tracé des résultats

  );progn si selbloc n'est pas vide
(princ "\n pas de bloc à lister \n")
);if 

  (princ)
  
  
  

  
;restaurer les paramètres initiaux
(command-s	"_-DIMSTYLE"		"R"	OLDCOTEXT	)
(command-s	"_-LAYER"	"L"	OLDCLAYER	"CH"	OLDCLAYER	"")
(setvar 	"attdia"	OLDATTDIA)
(setvar		"attreq"	OLDATTREQ)
(setvar		"OSMODE"	OLDOSMODE)
(setq 		*error* 	OLDERROR)
(setvar		"cmleaderstyle" OLDCMLEADERSTYLE)
(setvar		"luprec"	OLDLUPREC)
(setvar		"auprec"	OLDAUPREC)



);defun
(princ)

;---------------------------------fin du programme principal--------------------------------------------------------------------------------------------------------
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(defun myerr()
  (prompt "\nERROR: Commande a echoue ")
  (command-s "._undo" "_e")
  (setq *error* OLDERROR)
);defun myerr


; Fonction LONGTOT développée par LUNA
(defun LONGTOT (  jsel  / make-list jsel i name lst lng lay ltp)
  (defun make-list (lst layer ltype long / ltlst)
    (if (setq ltlst (assoc layer lst))
      (subst
        (cons
          layer
          (if (assoc ltype (cdr ltlst))
            (subst
              (cons ltype (+ long (cdr (assoc ltype (cdr ltlst)))))
              (assoc ltype (cdr ltlst))
              (cdr ltlst)
            )
            (append (cdr ltlst) (list (cons ltype long)))
          )
        )
        ltlst
        lst
      )
      (append lst (list (cons layer (list (cons ltype long)))))
    )
  ) ;fonction make-list développée par LUNA
  (repeat (setq i (sslength jsel))
        (setq
          name (ssname jsel (setq i (1- i)))
          lng (getpropertyvalue name "LENGTH")
          lay (cdr (assoc 8 (entget name)))
          ltp (if (assoc 6 (entget name)) (cdr (assoc 6 (entget name))) "ByLayer")
          lst (make-list lst lay ltp lng)
        )
      )
      (mapcar
        '(lambda (x / lay ltp lng)
          (princ
            (strcat
              "\nLongueur du calque \""
              (setq lay (car x))
              "\" = "
              (rtos (apply '+ (mapcar 'cdr (cdr x))) 2 2)
              (apply
                'strcat
                (mapcar
                  '(lambda (l)
                    (strcat
                      "\n - "
                      (car l)
                      " = "
                      (rtos (cdr l) 2 2)
                    )
                   )
                  (vl-sort (cdr x) '(lambda (e1 e2) (< (car e1) (car e2))))
                )
              )
            )
          )
         )
        (vl-sort lst '(lambda (e1 e2) (< (car e1) (car e2))))
      )
  (princ)
) ;defun LONGTOT

;; GETATTRIBUTE de LEE MAC
;; Retourne une liste d'association des attributs du bloc
(defun getattributevalues ( blk / enx lst )
    (while (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
        (setq lst
            (cons
                (cons
                    (cdr (assoc 2 enx))
                    (cdr (assoc 1 (reverse enx)))
                )
                lst
            )
        )
    )
    (reverse lst)
)

Je vais continuer sur les hachures, ca devrait être simple à partir du modèle des longueurs.

Bien à vous,

Modifié le 12 janvier 2022 par jujugeometre
j'ai compris la réponse à une question posée dans mon post

Luna · le 12 janvier 2022

Coucou,

Pour ton 4 qui sort à la fin c'est normal, il faut juste que tu mettes ton (princ) avant de clore ton (defun), comme ci-dessous, car sinon ton programme renvoie la valeur de 'OLDAUPREC' :

);defun
(princ)

;; Remplace le par :

(princ)
);defun

Désolée, pour le moment je n'ai pas vraiment de temps pour travailler sur ma fonction (princ-a-list-properties) mais je ne l'ai pas oubliée ! Je suis incapable de laisser une question en suspend comme chat, c'est bien trop frustrant donc cela me prendra le temps qu'il faudra pour sortir une version clean et pouvoir ainsi avoir une liste de fonctions connexes pour pouvoir générer un quantitatif d'objets selon un ordre précis de propriétés. (donc cela devrait solutionner plusieurs problèmes à la fois, espérons-le !)

Évidemment le plus dur sera de comprendre l'étendu d'utilisation des fonctions xD

Bisous,
Luna

Longueur cumulée en fonction du calque et du type de ligne

Messages recommandés

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Lien vers le commentaire

Partager sur d’autres sites

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Information importante