Polyligne 2D en 3D depuis Attribut de blocs

[Mfruncad]

Bonjour, 

Je souhaite transformer une polyligne 2D en polyligne 3D, à partir d'un attribut de blocs.

J'ai des blocs sur chaque sommet comme ci-dessous, mais les sommets de ma polyligne ont une élévation à 0.

Existe t-il un Lisp pour que l'attribut "Altitude_GS" devienne l'élévation du sommet correspondant : 

Et si possible sans passer par Covadis 😬

Merci d'avance pour votre aide !

[Fraid]

Bonjour,

Un petit lisp qui fait ce que tu demande.

Si il n'y a pas de bloc à une poignée, c'est le z précédant qui est utilisé.

Du coup il faut obligatoirement un bloc sur la première poignée.

; Chargement des fonctions VLA/Activex.
(vl-load-com)
; getpt3dpol, récupère la liste des points d'une polyligne 2D ou 3D
(defun getpt3dpol (ent / n pts)
    (if (= (type ent) 'VLA-OBJECT) (setq ent (vlax-vla-object->ename ent)))
    (setq n (1+ (fix (vlax-curve-getEndParam ent))))
    (repeat n
        (setq pts (cons (vlax-curve-getPointAtParam ent (setq n (1- n))) pts)))
)
(defun c:pol2d3dbyattrib ( / acdc mod lpt nlpt nlpt nlpts z flag)
    (setq acdc (vla-get-activedocument (vlax-get-acad-object))
          mod  (vla-get-modelspace acdc)
    )
    (vlax-for obj mod
        (if (= (vla-get-ObjectName obj) "AcDbPolyline")
            (progn
                (setq lpt (getpt3dpol obj) nlpt '() z 0.0)
                (foreach pt lpt
                    (setq flag nil)
                    (vlax-for bl mod
                        (if (and (= (vla-get-ObjectName bl) "AcDbBlockReference")
                                 (= (vla-get-hasAttributes bl) :vlax-true)
                                 (member pt (list (vlax-get bl 'InsertionPoint)))
                            )
                            (foreach att (vlax-invoke bl 'GetAttributes)
                                (if (= (vla-get-TagString att) "Altitude_GS")
                                    (setq z (atof (vla-get-textstring att)) nlpt (cons (list (car pt) (cadr pt) z) nlpt) flag 1)
                                )
                            )
                        )
                    )
                    (if (not flag) (setq nlpt (cons (list (car pt) (cadr pt) z) nlpt)))
                )
                (if nlpt
                    (progn
                        (setq nlpt (apply 'append (mapcar '(lambda (x)(list (car x) (cadr x) (caddr x))) nlpt))
                              nlpts (vlax-make-safearray vlax-vbDouble (cons 0 (- (length nlpt) 1))))
                        (vlax-safearray-fill nlpts nlpt)
                        (vla-Add3DPoly mod nlpts)
                    )
                
                )
                
            )
        
        )
    )
    (princ)
)

 

[bonuscad]

Bonjour,

Un peu similaire a Fraid.

Un dessin exemple aurait été utile pour tester le code, il est possible qu'il ne fonctionne pas.

(vl-load-com)
(defun c:test ( / ss_pl AcDoc Space n ent vla_obj dxf_ent prm lst_pt pt ss_blk obj lst_att val nw_pl)
  (princ "\nSélectionner les polylignes")
  (setq ss_pl
    (ssget
      (list
        (cons 0 "*POLYLINE")
        (cons 67 (if (eq (getvar "CVPORT") 2) 0 1))
        (cons 410 (if (eq (getvar "CVPORT") 2) "Model" (getvar "CTAB")))
        (cons -4 "<NOT")
         (cons -4 "&") (cons 70 126)
        (cons -4 "NOT>")
      )
    )
  )
  (setq
    AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    Space
    (if (eq (getvar "CVPORT") 1)
      (vla-get-PaperSpace AcDoc)
      (vla-get-ModelSpace AcDoc)
    )
  )
  (cond
    (ss_pl
      (repeat (setq n (sslength ss_pl))
        (setq
          ent (ssname ss_pl (setq n (1- n)))
          vla_obj (vlax-ename->vla-object ent)
          dxf_ent (entget ent)
          prm -1
          lst_pt nil
        )
        (repeat
          (if (zerop (boole 1 0 (cdr (assoc 70 dxf_ent))))
            (1+ (fix (vlax-curve-getEndParam ent)))
            (fix (vlax-curve-getEndParam ent))
          )
          (setq
            pt (vlax-curve-GetPointAtParam ent (setq prm (1+ prm)))
            ss_blk
            (ssget "_X"
              (list
                '(0 . "INSERT")
                '(2 . "IC_11_*")
                '(-4 . "<AND")
                  '(-4 . ">=,>=,*") (cons 10 pt)
                  '(-4 . "<=,<=,*") (cons 10 pt)
                '(-4 . "AND>")
              )
            )
            val
            (cond
              ((and ss_blk (eq (sslength ss_blk) 1))
                (setq
                  obj (vlax-ename->vla-object (ssname ss_blk 0))
                  lst_att
                  (mapcar
                    '(lambda (x) (cons (vla-get-TagString x) (vla-get-TextString x)))
                    (vlax-invoke Obj 'GetAttributes)
                  )
                  val (atof (cdr (assoc "Altitude_GS" lst_att)))
                  lst_pt (cons (list (car pt) (cadr pt) val) lst_pt)
                )
              )
            )
          )
        )
        (if (> (length lst_pt) 1)
          (progn
            (setq nw_pl (vlax-invoke Space 'Add3DPoly (apply 'append lst_pt)))
            (vla-put-Layer nw_pl (vla-get-Layer vla_obj))
            (vla-put-Closed nw_pl (vla-get-Closed vla_obj))
            (vla-put-Color nw_pl (vla-get-Color vla_obj))
            (vla-put-Linetype nw_pl (vla-get-Linetype vla_obj))
            (vla-put-LinetypeScale nw_pl (vla-get-LinetypeScale vla_obj))
            (vla-Update nw_pl)
            ;(vla-Delete vla_obj)
          )
        )
      )
    )
  )
  (prin1)
)

 

Modifié le 5 février par bonuscad
Mise à jour du code

[Mfruncad]

Merci beaucoup @Fraid et @bonuscad je vais tester ça !

Voici un exemple de fichier : test.dwg

[bonuscad]

@Mfruncad Merci pour le fichier exemple.

Après de mineures modifications, mon code (que j'ai mis à jour dans mon post précédent) semble fonctionner.

NB: Si tu veux supprimer l'entité originale dé-commente (enlever le point virgule) à la ligne 78 ;(vla-Delete vla_obj)