Effacer une ou plusieurs applications de XDATA

[bonuscad]

Bonjour,

J'ai un membre (russe:alexander) d'un forum autodesk (surtout autocad map) qui me sollicite assez souvent pour améliorer des routines: il a toujours des remarques fondées et des suggestions pour rendre l'application fonctionnelle à bon nombres d'utilisateurs.

Sa dernière demande concernait les Xdata (donc version classique ou Map)

Il désirait pouvoir effacer certaines application XData et en garder d'autres.

Ce qui m'a valu de pondre une version générique de cette fonction (avec une fonction:listbox que j'utilise beaucoup: un grand merci à gilles Chanteau)

Voici le code que j'ai transmit à Alexander, qu'il pourra éventuellement publier aussi sur son site.

;; ListBox (gile)
;; Boite de dialogue permettant un ou plusieurs choix dans une liste
;;
;; Arguments
;; title : le titre de la boite de dialogue (chaîne)
;; msg ; message (chaîne), "" ou nil pour aucun
;; keylab : une liste d'association du type ((key1 . label1) (key2 . label2) ...)
;; flag : 0 = liste déroulante
;; 1 = liste choix unique
;; 2 = liste choix multipes
;;
;; Retour : la clé de l'option (flag = 0 ou 1) ou la liste des clés des options (flag = 2)
;;
;; Exemple d'utilisation
;; (listbox "Présentation" "Choisir une présentation" (mapcar 'cons (layoutlist) (layoutlist)) 1)
(vl-load-com)
(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 ListBox (title msg keylab flag / tmp file dcl_id choice)
  (setq
    tmp (vl-filename-mktemp "tmp.dcl")
    file (open tmp "w")
  )
  (write-line
    (strcat "ListBox:dialog{label=\"" title "\";")
    file
  )
  (if (and msg (/= msg ""))
    (write-line (strcat ":text{label=\"" msg "\";}") file)
  )
  (write-line
    (cond
      ((= 0 flag) "spacer;:popup_list{key=\"lst\";")
      ((= 1 flag) "spacer;:list_box{key=\"lst\";width=32;")
      (T "spacer;:list_box{key=\"lst\";width=32;multiple_select=true;")
    )
    file
  )
  (write-line "}ok_cancel_err;}" file)
  (close file)
  (setq dcl_id (load_dialog tmp))
  (if (not (new_dialog "ListBox" dcl_id))
    (exit)
  )
  (start_list "lst")
  (mapcar 'add_list (mapcar 'cdr keylab))
  (end_list)
  (action_tile
    "accept"
    "(or (= (get_tile \"lst\") \"\")
      (if (= 2 flag)
        (progn
          (foreach n (str2lst (get_tile \"lst\") \" \")
            (setq choice (cons (nth (atoi n) (mapcar 'car keylab)) choice))
          )
          (setq choice (reverse choice))
        )
        (setq choice (nth (atoi (get_tile \"lst\")) (mapcar 'car keylab)))
      )
    )
    (done_dialog)"
  )
  (start_dialog)
  (unload_dialog dcl_id)
  (vl-file-delete tmp)
  choice
)
(defun c:remove_Xdata ( / js n ent_name dxf_ent apps lst_apps sel_app)
  (princ "\nSélectionner les objets auxquels retirer des XData.")
; (or
    (setq js (ssget "_I" '((-3 ("*")))))
;   (setq js (ssget "_P" '((-3 ("*")))))
; )
  (cond
    ((null js)
      (initget "Selection Tout _Select All")
      (if (eq (getkword "\nTraiter un jeu de [Selection/Tout] <Selection>: ") "All")
        (setq js (ssadd) js (ssget "_X" '((-4 . "<AND") (-4 . "<NOT") (-3 ("ACAD")) (-4 . "NOT>") (-3 ("*")) (-4 . "AND>"))))
        (setq js (ssadd) js (ssget '((-4 . "<AND") (-4 . "<NOT") (-3 ("ACAD")) (-4 . "NOT>") (-3 ("*")) (-4 . "AND>"))))
      )
    )
  )
  (cond
    (js
      (sssetfirst nil js)
      (repeat (setq n (sslength js))
        (setq
          ent_name (ssname js (setq n (1- n)))
          dxf_ent (entget ent_name (list "*"))
          apps (cdr (assoc -3 dxf_ent))
        )
        (foreach el apps
          (if (not (member (car el) lst_apps)) (setq lst_apps (cons (car el) lst_apps)))
        )
      )
      (setq lst_apps (vl-remove "ACAD" (vl-sort lst_apps '<)))
      (if lst_apps
        (setq sel_app (listbox "Applications" "Choisir l'application" (mapcar 'cons lst_apps lst_apps) 2))
        (setq lst_apps nil)
      )
      (cond
        (sel_app
          (setq js (ssget "_P" (list (list -3 (list (apply 'strcat (mapcar '(lambda (x) (strcat x ",")) sel_app)))))))
          (cond
            (js
              (repeat (setq n (sslength js))
                (setq
                  ent_name (ssname js (setq n (1- n)))
                  dxf_ent (entget ent_name '("*"))
                )
                (foreach el sel_app
                  (entmod (list (cons -1 ent_name) (list -3 (list el))))
                )
              )
              (princ (strcat "\nLes applications " (apply 'strcat (mapcar '(lambda (x) (strcat x ",")) sel_app)) " ont été supprimées pour " (itoa (sslength js)) " objets."))
            )
            (T (princ "\nPas d'applications corespondantes trouvée"))
          )
        )
        (T (princ "\nAucune application trouvée dans la sélection."))
      )
    )
  )
  (prin1)
)

Édité pour amélioration de la sélection qui n'est plus tous les objets, tri alphabétique des applications dans la boite de dialogue...

[lecrabe]

Hello @bonuscad

MERCI superbe routine ! ... Testee et validee sur AutoCAD MAP 2021 ...

Le sujet est LA : https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/programs-for-xdata/td-p/10423416

J'ai commence a rajouter des routines ...

La Sante, Bye, lecrabe (triste & fatigue)

 

[bonuscad]

Suite à des dysfonctionnements observé par Alexander, j'ai revu le code.

J'ai abandonné l'usage de (entdel) et (entmake) pour utiliser essentiellement (entmod) qui se révèle plus fiable.

J'ai modifié le 1er post.

[bonuscad]

Et toujours dans les XData en complément, une fonction pour lire les données attachées; similaire à xdlist des expresstools, mais les données sont lues en dynamique dès le survol d'une entité ayant des données étendues (plus pratique à mon goût que de relancer xdlist à chaque fois et refaire une sélection).

Seule restriction lors de l'usage, NE PAS UTILISER "Esc/Echap": c'est la seule touche qui ne peut être gérée avec (grread), toutes autres touches ou action de clic sur la souris mettra fin à la fonction.

Si vous le faites vous aurez un MText ajouté dans votre dessin qu'il faudra supprimer par vous même...

(vl-load-com)
(defun c:dyn_read_xdata ( / AcDoc Space UCS save_ucs WCS nw_obj ent_text dxf_ent apps lst_apps data ncol strcatlst Input obj_sel ename)
  (setq
    AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    Space
    (if (= 1 (getvar "CVPORT"))
      (vla-get-PaperSpace AcDoc)
      (vla-get-ModelSpace AcDoc)
    )
    UCS (vla-get-UserCoordinateSystems AcDoc)
    save_ucs
    (vla-add UCS
      (vlax-3d-point '(0.0 0.0 0.0))
      (vlax-3d-point (getvar "UCSXDIR"))
      (vlax-3d-point (getvar "UCSYDIR"))
      "CURRENT_UCS"
    )
  )
  (vla-put-Origin save_ucs (vlax-3d-point (getvar "UCSORG")))
  (setq WCS (vla-add UCS (vlax-3d-Point '(0.0 0.0 0.0)) (vlax-3d-Point '(1.0 0.0 0.0)) (vlax-3d-Point '(0.0 1.0 0.0)) "TEMP_WCS"))
  (vla-put-activeUCS AcDoc WCS)
  (setq
    nw_obj
    (vla-addMtext Space
      (vlax-3d-point (trans (getvar "VIEWCTR") 1 0))
      0.0
      ""
    )
  )
  (mapcar
    '(lambda (pr val)
      (vlax-put nw_obj pr val)
    )
    (list 'AttachmentPoint 'Height 'DrawingDirection 'StyleName 'Layer 'Rotation 'BackgroundFill 'Color)
    (list 1 (/ (getvar "VIEWSIZE") 100.0) 5 (getvar "TEXTSTYLE") (getvar "CLAYER") 0.0 -1 176)
  )
  (setq
    ent_text (entlast)
    dxf_ent (entget ent_text)
    dxf_ent (subst (cons 90 1) (assoc 90 dxf_ent) dxf_ent)
    dxf_ent (subst (cons 63 254) (assoc 63 dxf_ent) dxf_ent)
  )
  (entmod dxf_ent)
  (while (and (setq Input (grread T 4 2)) (= (car Input) 5))
    (cond
      ((setq obj_sel (nentselp (cadr Input)))
        (if (eq (type (car (last obj_sel))) 'ENAME)
          (if (member (cdr (assoc 0 (entget (car (last obj_sel))))) '("INSERT" "ACAD_TABLE" "DIMENSION"))
            (if
              (or
                (eq (cdr (assoc 0 (entget (car (last obj_sel))))) "ACAD_TABLE")
                (not (eq (boole 1 (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 (entget (car (last obj_sel)))))))) 4) 4))
              )
              (setq obj_sel (cons (car (last obj_sel)) '((0.0 0.0 0.0))))
            )
          )
        )
        (setq
          dxf_ent (entget (car obj_sel) (list "*"))
        )
        (if (eq (cdr (assoc 0 dxf_ent)) "VERTEX")
          (progn
            (while (eq (cdr (assoc 0 dxf_ent)) "VERTEX")
              (setq dxf_ent (entget (entnext (cdar dxf_ent))))
            )
            (setq dxf_ent (entget (cdr (assoc -2 dxf_ent)) (list "*")))
          )
        )
        (setq
          apps (cdr (assoc -3 dxf_ent))
          ncol 0
          lst_apps nil
        )
        (if apps
          (foreach el apps
            (if (not (member (car el) lst_apps)) (setq lst_apps (cons (car el) lst_apps)))
          )
        )
        (if lst_apps
          (foreach xd lst_apps
            (setq
              data (assoc xd apps)
              strcatlst
              (strcat
                (if strcatlst strcatlst "")
                (apply 'strcat
                  (mapcar
                    '(lambda (x)
                      (if (listp x)
                        (strcat
                          "("
                          (itoa (car x))
                          " . "
                          (cond
                            ((eq (car x) 1002) (strcat (if (eq (cdr x) "{") "\"(\"" "\")\"")))
                            ((member (car x) '(1000 1003 1004 1005)) (strcat "\"" (cdr x) "\""))
                            ((member (car x) '(1040 1041 1042)) (rtos (cdr x)))
                            ((member (car x) '(1070 1071)) (itoa (cdr x)))
                            ((member (car x) '(1010 1011 1012 1013 1020 1021 1022 1023 1030 1031 1032 1033)) (strcat "(" (rtos (cadr x)) "," (rtos (caddr x)) "," (rtos (cadddr x)) ")"))
                          )
                          ")\\P"
                        )
                        (strcat "{\\C" (itoa (setq ncol (+ 10 ncol))) " " (car data)"}" "\\P")
                      )
                    )
                    data
                  )
                )
              )
            )
          )
        )
        (if strcatlst
          (progn
            (mapcar 
              '(lambda (pr val)
                (vlax-put nw_obj pr val)
              )
              (list 'InsertionPoint 'Height 'TextString)
              (list (mapcar '- (getvar "VIEWCTR") (list (* (getvar "VIEWSIZE") 0.5) (- (* (getvar "VIEWSIZE") 0.5)) 0.0)) (/ (getvar "VIEWSIZE") 100.0) (strcat "{\\fArial;" strcatlst "}" ))
            )
          )
          (vlax-put nw_obj 'TextString "")
        )
        (setq strcatlst nil)
      )
      (T (vlax-put nw_obj 'TextString ""))
    )
  )
  (vla-Delete nw_obj)
  (and save_ucs (vla-put-activeUCS AcDoc save_ucs))
  (and WCS (vla-delete WCS) (setq WCS nil))
  (prin1)
)

NB: La fonction fonctionne aussi sur les xrefs. Vous pouvez avoir les information des objets imbriqués sans ouvrir le dessin constituant l'Xref.

Modifié le 24 mai 2022 par bonuscad
Edité le 24 05 2022 : correction pour utilisation dans un SCU

[l56]

Merci à vous pour cette apport.

Très utile.

Bonne journée à tous

L56