Lisp pour sélectionner les blocs qui sont uniquement sur des sommets de polylignes 2D

[Lekhito39]

Bonjour à tous

je suis à la recherche d'un lisp permettant de sélectionner des blocs qui ont des points d'insertion aux sommets de polylignes 2D

J'ai trouvé une partie de la réponse à ma question sur le sujet joint sauf qu'elle ne prends en compte que les polylignes 3D

Merci d'avance

[Luna]

Coucou,
Est-ce que quelque chose comme chat fonctionne pour toi ? C'est un peu bancal mais bon, chat fonctionne dans l'ensemble.

(defun c:LINSELB (/ get-pt-list blc mode jsel i name pt-lst tmp n obj)
  (defun get-pt-list (name / rp f o s e i l)
    (defun rp (p f)
      (mapcar '(lambda (c) (if (equal c 0.0 f) 0.0 c)) p)
    )
    
    (and
      name
      (setq f 1e-15)
      (setq o (cdr (assoc 0 (entget name))))
      (member o '("LWPOLYLINE" "POLYLINE" "LINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE"))
      (setq s (vlax-curve-getStartParam name))
      (setq e (vlax-curve-getEndParam name))
      (cond
        ( (member o '("LWPOLYLINE" "POLYLINE"))
          (repeat (setq i (1+ (fix e)))
            (setq l (cons (rp (vlax-curve-getPointAtParam name (setq i (1- i))) f) l))
          )
        )
        ( (member o '("LINE" "SPLINE"))
          (setq l
            (list
              (rp (vlax-curve-getPointAtParam name s) f)
              (rp (vlax-curve-getPointAtParam name e) f)
            )
          )
        )
        ( (member o '("ARC" "CIRCLE" "ELLIPSE"))
          (setq l
            (list
              (rp (cdr (assoc 10 (entget name))) f)
              (rp (vlax-curve-getPointAtParam name s) f)
              (rp (vlax-curve-getPointAtParam name e) f)
            )
          )
        )
      )
    )
    l
  )
  (and
    (setq blc (ssadd))
    (not (initget "Sommet Trajet"))
    (setq mode (cond ((getkword "\nSélectionner les blocs selon [Sommet/Trajet] <Sommet> : ")) ("Sommet")))
    (setq jsel (ssget '((0 . "LWPOLYLINE,POLYLINE,LINE"))))
    (repeat (setq i (sslength jsel))
      (setq
        name (ssname jsel (setq i (1- i)))
        pt-lst (get-pt-list name)
        tmp (ssget "_F" pt-lst '((0 . "INSERT")))
      )
      (repeat (setq n (sslength tmp))
        (setq
          obj (ssname tmp (setq n (1- n)))
          pt (cdr (assoc 10 (entget obj)))
        )
        (cond
          ( (= mode "Trajet")
            (ssadd obj blc)
          )
          ( (= mode "Sommet")
            (if (member T (mapcar '(lambda (p) (equal p pt 10e-2)) pt-lst))
              (ssadd obj blc)
            )
          )
        )
      )
      blc
    )
    (not (sssetfirst))
    (princ
      (strcat
        "\nUn total de "
        (itoa (sslength blc))
        " blocs ont été sélectionnés à partir des "
        (itoa (sslength jsel))
        " polylignes/lignes sélectionnés."
      )
    )
    (sssetfirst nil blc)
  )
  (princ)
)

Bisous,
Luna

[Lekhito39]

J'ai essayé le lisp précédent mais je n'ai pas le résultat escompté.

Pour mieux me faire comprendre, similairement au sujet joint au premier message, je souhaiterais que les étiquettes (bloc "DETECT") soient attribués au calque de la polyligne 2D sélectionnée.

Pour donner un ordre d'idée, dans mon fichier brut, j'ai 6779 étiquettes à attribuer en fonction du type de réseau (élec BT, élec HTA, télecom, AEP, EP, EU ...)

j'ai joint une partie du fichier concerné 🙂

[Luna]

Coucou,
Oki, dans ce cas chat change tout ^^
Cela te convient-il mieux ?

(defun c:ChangeLayerBlockOnVertex (/ jsel ss_blk ss_poly i ent_poly nam_lay lst_pt n ent_blk dxf_blk pt)
  (and
    (setq jsel (ssadd))
    (setq ss_blk (ssget "_X" '((0 . "INSERT") (2 . "DETECT,`*U*"))))
    (setq ss_poly (ssget '((0 . "LWPOLYLINE"))))
    (repeat (setq i (sslength ss_poly))
      (setq
        ent_poly (ssname ss_poly (setq i (1- i)))
        nam_lay (assoc 8 (entget ent_poly))
        lst_pt (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget ent_poly)))
      )
      (repeat (setq n (sslength ss_blk))
        (setq
          ent_blk (ssname ss_blk (setq n (1- n)))
          dxf_blk (entget ent_blk)
          pt (cdr (assoc 10 dxf_blk))
        )
        (mapcar
          '(lambda (x)
            (if
              (and
                (= "DETECT" (vla-get-EffectiveName (vlax-ename->vla-object ent_blk)))
                (equal (list (car pt) (cadr pt)) (list (car x) (cadr x)) 1E-08)
              )
              (progn
                (entmod (subst nam_lay (assoc 8 dxf_blk) dxf_blk))
                (ssadd ent_blk jsel)
              )
            )
          )
          lst_pt
        )
        T
      )
    )
    (null (sssetfirst))
    (princ (strcat "\nUn total de " (itoa (sslength jsel)) "/" (itoa (sslength ss_blk)) " bloc(s) \"DETECT\" ont été modifiés"))
    (sssetfirst nil jsel)
  )
  (princ)
)

Bisous,
Luna

[Lekhito39]

Bonjour,

Rien à dire, C'est exactement ça. Je suis subjugué par la manière dont on peut faire les Lisps.

Par ailleurs je remarque que le Lisp prends bien en compte que la sélection du bloc "DETECT", je souhaiterai savoir quel est le()s paramètre(s) à changer si je veux qu'il fasse la même tâche pour un bloc quelconque.

Sinon c'est Parfait merci du gros coup de pouce.👍🙂

 

[Luna]

Coucou,
Je te propose la version modifiée pour regrouper le nom du bloc sous forme de variable donc comme chat il suffit de le modifier une seule fois au début. Si jamais, je peux également ajouter une question pour rentrer le nom du bloc ou bien je peux aussi ouvrir une boîte de dialogue pour sélectionner les blocs dans une liste.

;; * Il est possible de spécifier plusieurs noms de blocs (utiliser une virgule ","), de faire des recherches relatives (cf. Wildcard Characters), etc...
;; /!\ Ne modifier que le texte situé entre les guillemets !
;; Exemple :
;;   - "DETECT,TCPOINT"  -> Le nom du bloc peut être "DETECT" ou bien "TCPOINT"
;;   - "*Point*"         -> Le nom du bloc doit contenir la chaîne de caractères "POINT" peut importe sa position (donc "TCPOINT" est sélectionné)
;;   /!\ La casse n'a pas d'importance, les noms seront comparés avec la même casse (MAJUSCULE).
(defun c:ChangeLayerBlockOnVertex (/ str2lst nam_blk jsel ss_blk ss_poly i ent_poly nam_lay lst_pt n ent_blk dxf_blk pt name)
  (defun str2lst (str sep / pos)
    (if (setq pos (vl-string-search sep str))
      (cons
        (substr str 1 pos)
        (str2lst (substr str (+ (strlen sep) pos 1)) sep)
      )
      (list str)
    )
  )
  (and
    (setq nam_blk (strcase "DETECT")) ;; <-- Entrer le(s) nom(s) des blocs* pour le filtre de sélection
    (setq jsel (ssadd))
    (setq ss_blk (ssget "_X" (list '(0 . "INSERT") (cons 2  (strcat nam_blk ",`*U*")))))
    (setq ss_poly (ssget '((0 . "LWPOLYLINE"))))
    (repeat (setq i (sslength ss_poly))
      (setq
        ent_poly (ssname ss_poly (setq i (1- i)))
        nam_lay (assoc 8 (entget ent_poly))
        lst_pt (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget ent_poly)))
      )
      (repeat (setq n (sslength ss_blk))
        (setq
          ent_blk (ssname ss_blk (setq n (1- n)))
          dxf_blk (entget ent_blk)
          pt (cdr (assoc 10 dxf_blk))
          name (strcase (vla-get-EffectiveName (vlax-ename->vla-object ent_blk)))
        )
        (mapcar
          '(lambda (x)
            (if
              (and
                (member T (mapcar '(lambda (x) (wcmatch x name)) (str2lst nam_blk ",")))
                (equal (list (car pt) (cadr pt)) (list (car x) (cadr x)) 1E-08)
              )
              (progn
                (entmod (subst nam_lay (assoc 8 dxf_blk) dxf_blk))
                (ssadd ent_blk jsel)
              )
            )
          )
          lst_pt
        )
        T
      )
    )
    (null (sssetfirst))
    (princ (strcat "\nUn total de " (itoa (sslength jsel)) "/" (itoa (sslength ss_blk)) " bloc(s) \"" nam_blk "\" ont été modifiés"))
    (sssetfirst nil jsel)
  )
  (princ)
)

Si tu as des questions, n'hésites pas 🙂

Bisous,
Luna

[Lekhito39]

A l'améliorer je dirai que l'ouverture d'une boîte de dialogue pour sélectionner les blocs dans une liste serait la solution la plus adéquate, permettant ainsi à tous de sélectionner le bloc concerné.

 

[Luna]

Oki doki, dis-moi si c'est good pour toi :3

(defun c:ChangeLayerBlockOnVertex (/ str2lst lst2str ListBox vla-collection->list nam_blk jsel ss_blk ss_poly i ent_poly nam_lay lst_pt n ent_blk dxf_blk pt name)
  (defun str2lst (str sep / pos)
    (if (setq pos (vl-string-search sep str))
      (cons
        (substr str 1 pos)
        (str2lst (substr str (+ (strlen sep) pos 1)) sep)
      )
      (list str)
    )
  )
  (defun lst2str (lst sep)
    (if lst
      (vl-string-left-trim
        sep
        (apply
          'strcat
          (mapcar '(lambda (x) (strcat sep (vl-princ-to-string x))) lst)
        )
      )
    )
  )
  (defun ListBox (title msg lst value flag h / vl-list-search LB-select tmp file DCL_ID choice tlst)
    (defun vl-list-search (p l)
      (vl-remove-if-not '(lambda (x) (wcmatch x p)) l)
    )
    
    (defun LB-select (str)
      (if (= "" str)
        "0 selected"
        (strcat (itoa (length (str2lst str " "))) " selected")
      )
    )
    
    (setq
      tmp (vl-filename-mktemp "tmp.dcl")
      file (open tmp "w")
      tlst lst
    )
    (write-line
      (strcat "ListBox:dialog{width=" (itoa (+ (apply 'max (mapcar 'strlen (mapcar 'vl-princ-to-string lst))) 5)) ";label=\"" title "\";")
      file
    )
    (write-line
      ":edit_box{key=\"filter\";}"
      file
    )
    (if (and msg (/= msg ""))
      (write-line (strcat ":text{label=\"" msg "\";}") file)
    )
    (write-line
      (cond
        ( (= 0 flag) "spacer;:popup_list{key=\"lst\";}")
        ( (= 1 flag) (strcat "spacer;:list_box{height=" (itoa (1+ (cond (h) (15)))) ";key=\"lst\";}"))
        ( T (strcat "spacer;:list_box{height=" (itoa (1+ (cond (h) (15)))) ";key=\"lst\";multiple_select=true;}:text{key=\"select\";}"))
      )
      file
    )
    (write-line ":text{key=\"count\";}" file)
    (write-line "spacer;ok_cancel;}" file)
    (close file)
    (setq DCL_ID (load_dialog tmp))
    (if (not (new_dialog "ListBox" DCL_ID))
      (exit)
    )
    (set_tile "filter" "*")
    (set_tile "count" (strcat (itoa (length lst)) " / " (itoa (length lst))))
    (start_list "lst")
    (mapcar 'add_list lst)
    (end_list)
    (set_tile
      "lst"
      (cond
        ( (and
            (= flag 2)
            (listp value)
          )
          (apply 'strcat (vl-remove nil (mapcar '(lambda (x) (if (member x lst) (strcat (itoa (vl-position x lst)) " "))) value)))
        )
        ( (member value lst) (itoa (vl-position value lst)))
        ( (itoa 0))
      )
    )
    (if (= flag 2)
      (progn
        (set_tile "select" (LB-select (get_tile "lst")))
        (action_tile "lst" "(set_tile \"select\" (LB-select $value))")
      )
    )
    (action_tile
      "filter"
      "(start_list \"lst\")
      (mapcar 'add_list (setq tlst (vl-list-search $value lst)))
      (end_list)
      (set_tile \"count\" (strcat (itoa (length tlst)) \" / \" (itoa (length lst))))"
    )
    (action_tile
      "accept"
      "(or 
        (= (get_tile \"lst\") \"\")
        (if (= 2 flag)
          (progn
            (foreach n (str2lst (get_tile \"lst\") \" \")
              (setq choice (cons (nth (atoi n) tlst) choice))
            )
            (setq choice (reverse choice))
          )
          (setq choice (nth (atoi (get_tile \"lst\")) tlst))
        )
      )
      (done_dialog)"
    )
    (start_dialog)
    (unload_dialog DCL_ID)
    (vl-file-delete tmp)
    choice
  )
  (defun vla-collection->list (doc col flag / lst item i)
    (if
      (null
        (vl-catch-all-error-p
          (setq
            i 0
            col (vl-catch-all-apply 'vlax-get (list (cond (doc) ((vla-get-activedocument (vlax-get-acad-object)))) col))
          )
        )
      )
      (vlax-for item col
        (setq lst
          (cons
            (cons
              (if (vlax-property-available-p item 'Name)
                (vla-get-name item)
                (strcat "Unnamed_" (itoa (setq i (1+ i))))
              )
              (cond
                ( (= flag 0) (vlax-vla-object->ename item))
                (item)
              )
            )
            lst
          )
        )
      )
    )
    (reverse lst)
  )
  (and
    (setq nam_blk (list "DETECT")) ;; <-- Entrer le(s) nom(s) des blocs pour le filtre de sélection
    (setq nam_blk
      (ListBox
        "Sélection du/des bloc(s)"
        "Veuillez sélectionner un ou plusieurs bloc(s) :"
        (vl-sort (vl-remove-if '(lambda (x) (wcmatch x "`**")) (mapcar 'car (vla-collection->list nil 'blocks 1))) '<)
        nam_blk
        2
        nil
      )
    )
    (setq jsel (ssadd))
    (setq ss_blk (ssget "_X" (list '(0 . "INSERT") (cons 2 (strcat (lst2str nam_blk ",") ",`*U*")))))
    (setq ss_poly (ssget '((0 . "LWPOLYLINE"))))
    (repeat (setq i (sslength ss_poly))
      (setq
        ent_poly (ssname ss_poly (setq i (1- i)))
        nam_lay (assoc 8 (entget ent_poly))
        lst_pt (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget ent_poly)))
      )
      (repeat (setq n (sslength ss_blk))
        (setq
          ent_blk (ssname ss_blk (setq n (1- n)))
          dxf_blk (entget ent_blk)
          pt (cdr (assoc 10 dxf_blk))
          name (vla-get-EffectiveName (vlax-ename->vla-object ent_blk))
        )
        (mapcar
          '(lambda (x)
            (if
              (and
                (member name nam_blk)
                (equal (list (car pt) (cadr pt)) (list (car x) (cadr x)) 1E-08)
              )
              (progn
                (entmod (subst nam_lay (assoc 8 dxf_blk) dxf_blk))
                (ssadd ent_blk jsel)
              )
            )
          )
          lst_pt
        )
        T
      )
    )
    (null (sssetfirst))
    (princ (strcat "\nUn total de " (itoa (sslength jsel)) "/" (itoa (sslength ss_blk)) " bloc(s) nommé(s) \"" (lst2str nam_blk ", ") "\" ont été modifié(s)"))
    (sssetfirst nil jsel)
  )
  (princ)
)

Bisous,
Luna

[Lekhito39]

Que demander de plus ? Le Lisp fonctionne parfaitement !

Je suis persuadé qu'il y aura bien du monde qui pourront l'utiliser dans l'avenir...

Merci encore ! 😁