[Résolu] Somme par calque mais sans le calque

[DenisHen]

Bonjour à la communauté.
J'ai fais un lisp pour cumuler les longueurs des LWPOLYLINE.
Si j'enlève le (cons 8 Calq), ça fonctionne, mais tout calques confondus. Si je le replace, je n'ai plus de calcul...
Voici mon code :
 

(defun MetreArmatTxt (/ MetreHaHo MetreNivHo MetreNbHo ArmatObj dxf_ent CalqObj Calq)
  (setq MetreHaHo ""
        i 0
        HA6Tot 0.0
        HA8Tot 0.0
        HA10Tot 0.0
        ;;;;;;; je n'ai pas tout collé
        HA40Tot 0.0
        Text ""
  ) ;_ Fin de setq
  ;; Sélectionner le calque pour le calcul...
  (setq Obj (entget (car (entsel "\nSélectionner le calque pour le métré :"))))
  (setq Calq (cdr (assoc 8 Obj)))
  (princ (strcat "\nCalque du calcul : " Calq "\n"))
  (if (setq Select (ssget "_X" (list (cons 0 "LWPOLYLINE") (cons 8 Calq) (cons 410 "Model"))))  ;;(cons 8 Calq)
    (progn
      (while (setq ent (ssname Select i))
        ;;(princ "\nDrapeau 02")
        (setq MetreHaHo (vlax-ldata-get ent "MetreHAHo"))
        (setq MetreNivHo (vlax-ldata-get ent "MetreNivHo" "1"))
        (setq MetreNbHo (vlax-ldata-get ent "MetreNbHo"))
        ;;(princ "\nDrapeau 05")
        (if (/= MetreHaHo nil)
          (cond ((= MetreHaHo "HA6")
                 (princ "\nDrapeau HA6")
                 (setq HA6Tot (+ HA6Tot (* (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (atoi MetreNbHo))))
                 ;;(princ (strcat "\nHa=" MetreHaHo "\tNb=" MetreNbHo "\tNiveau=" MetreNivHo))
                )
                ((= MetreHaHo "HA8")
                 (princ "\nDrapeau HA8")
                 (setq HA8Tot (+ HA8Tot (* (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (atoi MetreNbHo))))
                 ;;(princ (strcat "\nHa=" MetreHaHo "\tNb=" MetreNbHo "\tNiveau=" MetreNivHo))
                )
                ((= MetreHaHo "HA10")
                 (princ "\nDrapeau HA10")
                 (setq HA10Tot (+ HA10Tot (* (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (atoi MetreNbHo))))
                 ;;(princ (strcat "\nHa=" MetreHaHo "\tNb=" MetreNbHo "\tNiveau=" MetreNivHo))
                )
                ;;;;;;;;;;;;;;;;;;;;;;;; je n'ai pas tout collé
                ((= MetreHaHo "HA40")
                 (princ "\nDrapeau HA40")
                 (setq HA40Tot (+ HA40Tot (* (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (atoi MetreNbHo))))
                 ;;(princ (strcat "\nHa=" MetreHaHo "\tNb=" MetreNbHo "\tNiveau=" MetreNivHo))
                )
          ) ;_ Fin de cond
        ) ;_ Fin de if
        (setq MetreHaHo nil)
        (setq i (1+ i))
      ) ;_ Fin de while
    ) ;_ Fin de progn
  ) ;_ Fin de if
  (if (not (tblsearch "style" "ChainH"))
    (command "-style" "ChainH" "arial.ttf" "" "" "" "" "" "")
    (command "textstyle" "ChainH")
  ) ;_ Fin de if
  (setq NbDec (getvar "luprec"))
  ;;(setq Pt_ins_Txt (getpoint "\nPoint d'insertion du texte : "))
  (setq Text "\\LLinéaire total des chaînages horizontaux :\\l\\P\\Q15(Hors recouvrement)\\Q0\\P")
  (if (/= HA6Tot 0)
    (setq Text (strcat Text "- HA6=" (rtos (/ HA6Tot 100) 2 NbDec) " m\n"))
  ) ;_ Fin de if
  (if (/= HA8Tot 0)
    (setq Text (strcat Text "- HA8=" (rtos (/ HA8Tot 100) 2 NbDec) " m\n"))
  ) ;_ Fin de if
  (if (/= HA10Tot 0)
    (setq Text (strcat Text "- HA10=" (rtos (/ HA10Tot 100) 2 NbDec) " m\n"))
  ) ;_ Fin de if
;;;;;;;;;;;;;;;;;;;;;;;; je n'ai pas tout collé
  (if (/= HA40Tot 0)
    (setq Text (strcat Text "- HA40=" (rtos (/ HA40Tot 100) 2 NbDec) " m"))
  ) ;_ Fin de if
  (princ)
)

Quelqu'un pourrait me dire où j'ai fais une erreur ?

[Luna]

Coucou,
Serait-il possible d'avoir un .dwg d'exemple pour voir pour quelle raison cela ne fonctionne pas ? Si je comprends bien, c'est le (cons 8 Calq) qui pose un souci dans le filtre (ssget) ?

Autrement, je pense que l'écriture du programme pourrait être grandement simplifiée en évitant de créer un ligne pour chaque valeur possible...J'avais créé 2 fonctions pour créer une liste d'association à plusieurs niveaux (il me manque encore la dernière pour pouvoir l'interpréter malheureusement...). Pour ton cas, la seconde fonction ne te servira à rien car elle ne permet pas encore de gérer les données étendues ou XDatas... Cependant tu peux essayer de voir avec la 1ère :

; +-----------------------------------------------------------------------------------------------------------------------------------------------+ ;
; |                                                                                                                                               | ;
; |                                                   HISTORICAL TRACKING FILE OF THE FUNCTION                                                    | ;
; |                                                        --{  make-a-list-properties  }--                                                       | ;
; |                                                                                                                                               | ;
; +-----------------------------------------------------------------------------------------------------------------------------------------------+ ;



;                                   []-----------------------[] make-a-list-properties []-----------------------[]                                  ;
;--- Date of creation       > 06/01/2022                                                                                                            ;
;--- Last modification date > 04/02/2022                                                                                                            ;
;--- Author                 > Luna                                                                                                                  ;
;--- Version                > 2.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 5 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, ...                                                                        ;
;   --•  flag                   > corresponds to the position of 'value' in relation to (cdr search), the actual value in the association list      ;
;     (type flag) = 'SYM                        | Ex. : T means 'value' is before (cdr search), nil means 'value' is after (cdr search)             ;
;                                                                                                                                                   ;
;--- List of dependent's functions                                                                                                                  ;
;   --•  "XxXxx" ---> ...                                           | v#.#.# - ##/##/#### (Luna)                                                    ;
;                                                                                                                                                   ;
;--- List of local functions                                                                                                                        ;
;   --•  "XxXxx" ---> ...                                           | v#.#.# - ##/##/#### (Luna)                                                    ;
;                                                                                                                                                   ;
;--- List of programs using this function                                                                                                           ;
;   --•  "BaLst" ---> loop-a-list-properties                        | v2.0.0 - 28/02/2022 (Luna)                                                    ;
;                                                                                                                                                   ;
;--- 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 '+ nil) 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                                                                                    ;
; +------------+----------------------------------------------------------------------------------------------------------------------------------+ ;
; |   v2.0.0   |   Adding an argument to define the position of 'value' (cdr search) in the list between each other                               | ;
; |            |   (i.e (list value (cdr search)) or (list (cdr search) value)) to adapt the program to different function (like  (cons) and (-)) | ;
; +------------+----------------------------------------------------------------------------------------------------------------------------------+ ;
; |   v1.0.0   |   Creation of the function                                                                                                       | ;
; +------------+----------------------------------------------------------------------------------------------------------------------------------+ ;
;                                                                                                                                                   ;

(defun make-a-list-properties (lst k-lst value fun flag / key search)
  (if (null (cdr k-lst))
    (if (setq search (assoc (setq key (car k-lst)) lst))
      (subst (cons key (apply fun (if flag (list value (cdr search)) (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 flag)) search lst)
      (append lst (list (cons key (make-a-list-properties (cdr search) (cdr k-lst) value fun flag))))
    )
  )
)

Pour ton utilisation, je peux te suggérer un programme de ce genre (à compléter et tester !) :

(defun foo (layer / jsel i name HaHo NvHo NbHo Lght lst text)
  (if (setq jsel (ssget "_X" (list '(0 . "LWPOLYLINE") (cons 8 layer) '(410 . "Model"))))
    (progn
      (repeat (setq i (sslength jsel))
        (and
          (setq name (ssname jsel (setq i (1- i))))
          (setq HaHo (vlax-ldata-get name "MetreHaHo"))
          (setq NvHo (vlax-ldata-get name "MetreNivHo" "1"))
          (setq NbHo (vlax-ldata-get name "MetreNbHo"))
          (setq Lgth (getpropertyvalue name "LENGTH"))
          (setq lst (make-a-list-properties lst (list HaHo) (* Lgth (cond ((distof NbHo)) (1))) '+ nil))
        )
      )
      (setq text "\\lLinéaire total des chaînages horizontaux :\\l\\P\\Q15(Hors recouvrement)\\Q0\\P")
;      (foreach x (vl-sort lst '(lambda (e1 e2) (< (car e1) (car e2))))
;        (setq text
;          (strcat
;            text
;            "- "
;            (car x)
;            "="
;            (rtos (/ (cdr x) 100) 2)
;            " m\n"
;          )
;        )
;      )
      (vl-sort lst '(lambda (e1 e2) (< (car e1) (car e2))))
    )
  )
)

Bisous,
Luna

Modifié le 21 juin 2022 par Luna
Correction du programme (foo)

[DenisHen]

Bonjour Luna, et merci pour ton aide.
Je vais regarder ton code avec le plus grand intérêt.
Voici mon DWG.

CadXP_(cons 8 Calq).zip

[DenisHen]

Je viens d'essayer avec ton (ssget :

(if (setq Select (ssget "_X" (list '(0 . "LWPOLYLINE") (cons 8 layer) '(410 . "Model"))))

Et AutoCAD me répond :
 

Citation

; erreur: valeur de liste SSGET incorrecte

Et je n'arrive à rien avec (lambda et (mapcar, j'aurais du mal à retoucher ton code. 😪

[Luna]

Oki doki !!
Alors vui, j'ai oublié de préciser mais (foo) possède le nom du calque en argument donc pour l'exemple tu pourrais avoir :

(foo (cdr (assoc 8 (entget (car (entsel))))))

Ensuite j'ai compris d'où provient le problème 😉
C'est le nom de ton calque qui ne plaît pas au (ssget) 🙂 J'ai essayé avec un autre calque et il n'y a plus de problème

J'ai modifié (foo) sur mon post précédent en corrigeant les erreurs détectées en le testant sur ton .dwg ^^
Pour ce qui est du nom du calque, je vais essayer de voir ce qu'on peut faire mais le soucis vient de là (Wildcard Characters) : https://knowledge.autodesk.com/support/autocad-map-3d/learn-explore/caas/CloudHelp/cloudhelp/2019/ENU/MAP3D-Use/files/GUID-BED8F649-3D1A-4641-A48F-562A2EBB927C-htm.html

Bisous,
Luna

[DenisHen]

Un milliard de merci, je ne comprenais plus rien ! ! !
Je pensais avoir fais une bêtise.
Heureusement il y a CadXP et ses merveilleux membres ! ! !
Encore merci Luna.

[Luna]

Je peux proposer ceci pour le nom du calque :

(defun read-str ( str / wcc )
  (setq wcc '("#" "@" "." "*" "%" "?" "~" "[" "]" "-" "`" ","))
  (setq str (mapcar 'chr (vl-string->list str)))
  (apply
    'strcat
    (mapcar
      '(lambda (s)
        (if (member s wcc)
          (strcat "`" s)
          s
        )
      )
      str
    )
  )
)

Ainsi il suffirait de remplacer

(cons 8 layer)

par

(cons 8 (read-str layer))

A tester si avec ton programme et/ou mon bout de programme

il y a 16 minutes, DenisHen a dit :

Un milliard de merci, je ne comprenais plus rien ! ! !
Je pensais avoir fais une bêtise.
Heureusement il y a CadXP et ses merveilleux membres ! ! !
Encore merci Luna.

Tout le plaisir est pour moi :3

Bisous,
Luna

[DenisHen]

Merci pour ton aide, mais j'avais déjà dis à mes collègues de ne pas mettre de caractères spéciaux dans les noms des calques (ni ailleurs Styles de texte, de ligne, de côtes...)
Je vais corrigé ces noms...
Encore merci à toi...