Cablage en polyligne

KSJ77 · le 10 décembre 2014

Bonjour,

Je souhaiterai de l'aide pour modifier le lisp ci dessous.

Il s'agit d'un lisp qui permettrait de relier des prises terminales informatique à une baie suivant un chemin de câble (le but final est de récupérer les longueurs et de les mettre en attribut dans chaques prises).

Je cherche à modifier ce dernier afin que les tracés s'effectuent suivant un tracé prédéfini d'un chemin de cable (en polyligne) et non en direct comme l'exemple joint.

Savez vous si il existe un lisp plus adéquate que celui ci?

Es ce que c'est possible avec ce lisp?

(defun l-coor2l-pt (lst flag / )
 (if lst
   (cons
     (list
       (car lst)
       (cadr lst)
       (if flag
         (+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst))
         (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
       )
     )
     (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
   )
 )
)
(defun c:CABLAGE_VDI ( / js dxf_cod mod_sel n lremov ename l_pt l_pr key)
 (princ "\nChoix d'un objet modèle pour le filtrage: ")
 (while
   (null
     (setq js
       (ssget "_+.:E:S"
         (list
           '(0 . "*LINE,POINT,ARC,CIRCLE,ELLIPSE,INSERT")
           (cons 67 (if (eq (getvar "CVPORT") 1) 1 0))
           (cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model"))
         )
       )
     )
   )
   (princ "\nCe n'est pas un objet valable pour cette fonction!")
 )
 (vl-load-com)
 (setq dxf_cod (entget (ssname js 0)))
 (foreach m (foreach n dxf_cod (if (not (member (car n) '(0 67 410 8 6 62 48 420 70))) (setq lremov (cons (car n) lremov))))
   (setq dxf_cod (vl-remove (assoc m dxf_cod) dxf_cod))
 )
 (initget "Unique Tout Manuel _Single All Manual")
 (if (eq (setq mod_sel (getkword "\nMode de sélection filtrée, choix [unique/Tout/Manuel]<Manuel>: ")) "Single")
   (setq n -1)
   (if (eq mod_sel "All")
       (setq js (ssget "_X" dxf_cod) n -1)
       (setq js (ssget dxf_cod) n -1)
   )
 )
 (repeat (sslength js)
   (setq ename (vlax-ename->vla-object (ssname js (setq n (1+ n)))))
   (setq l_pr (list 'StartPoint 'EndPoint 'Center 'InsertionPoint 'Coordinates 'FitPoints))
   (foreach n l_pr
     (if (vlax-property-available-p ename n)
       (setq l_pt
         (if (or (eq n 'Coordinates) (eq n 'FitPoints))
           (append
             (if (eq (vla-get-ObjectName ename) "AcDbPolyline")
               (l-coor2l-pt (vlax-get ename n) nil)
               (if (and (eq n 'FitPoints) (zerop (vlax-get ename 'FitTolerance)))
                 (l-coor2l-pt (vlax-get ename 'ControlPoints) T)
                 (l-coor2l-pt (vlax-get ename n) T)
               )
             )
             l_pt
           )
           (cons (vlax-get ename n) l_pt)
         )
       )
     )
   )
 )
 (cond
   (l_pt
     (while (and (setq key (grread T 4 0)) (/= (car key) 3))
       (redraw)
       (cond
         ((eq (car key) 5)
           (foreach n l_pt
             (grdraw (trans n 0 1) (cadr key) 3)
           )
         )
       )
     )
     (if (eq (car key) 3) 
       (foreach n l_pt
         (command "_pline" "_none" (trans n 0 1) "_none" (cadr key) "")
       )
     )
     (redraw)
   )
 )
 (prin1)
)

Merci d'avance à ceux qui pourront m'aider

Cablage VDI.zip

bonuscad · le 10 décembre 2014

Bonjour,

Je cherche à modifier ce dernier

:(rires forts): :(rires forts): :(rires forts):

Je trouve que tu n'as pas beaucoup cherché, il est tel que je l'avais posté sur CadXp, mis à part le nom de la fonction qui a changé.

Bon je vais être bon prince... essayes le sous cette forme. Mais je n'irais pas plus loin!

(defun l-coor2l-pt (lst flag / )
 (if lst
   (cons
     (list
       (car lst)
       (cadr lst)
       (if flag
         (+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst))
         (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
       )
     )
     (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
   )
 )
)
(defun c:CABLAGE_VDI ( / js dxf_cod mod_sel n lremov ename l_pt l_pr key js_cl obj_vlax pr lst_pt pt pt_cl)
 (princ "\nChoix d'un objet modèle pour le filtrage: ")
 (while
   (null
     (setq js
       (ssget "_+.:E:S"
         (list
           '(0 . "*LINE,POINT,ARC,CIRCLE,ELLIPSE,INSERT")
           (cons 67 (if (eq (getvar "CVPORT") 1) 1 0))
           (cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model"))
         )
       )
     )
   )
   (princ "\nCe n'est pas un objet valable pour cette fonction!")
 )
 (vl-load-com)
 (setq dxf_cod (entget (ssname js 0)))
 (foreach m (foreach n dxf_cod (if (not (member (car n) '(0 67 410 8 6 62 48 420 70))) (setq lremov (cons (car n) lremov))))
   (setq dxf_cod (vl-remove (assoc m dxf_cod) dxf_cod))
 )
 (initget "Unique Tout Manuel _Single All Manual")
 (if (eq (setq mod_sel (getkword "\nMode de sélection filtrée, choix [unique/Tout/Manuel]<Manuel>: ")) "Single")
   (setq n -1)
   (if (eq mod_sel "All")
       (setq js (ssget "_X" dxf_cod) n -1)
       (setq js (ssget dxf_cod) n -1)
   )
 )
 (repeat (sslength js)
   (setq ename (vlax-ename->vla-object (ssname js (setq n (1+ n)))))
   (setq l_pr (list 'StartPoint 'EndPoint 'Center 'InsertionPoint 'Coordinates 'FitPoints))
   (foreach n l_pr
     (if (vlax-property-available-p ename n)
       (setq l_pt
         (if (or (eq n 'Coordinates) (eq n 'FitPoints))
           (append
             (if (eq (vla-get-ObjectName ename) "AcDbPolyline")
               (l-coor2l-pt (vlax-get ename n) nil)
               (if (and (eq n 'FitPoints) (zerop (vlax-get ename 'FitTolerance)))
                 (l-coor2l-pt (vlax-get ename 'ControlPoints) T)
                 (l-coor2l-pt (vlax-get ename n) T)
               )
             )
             l_pt
           )
           (cons (vlax-get ename n) l_pt)
         )
       )
     )
   )
 )
 (cond
   (l_pt
     (while (and (setq key (grread T 4 0)) (/= (car key) 3))
       (redraw)
       (cond
         ((eq (car key) 5)
           (foreach n l_pt
             (grdraw (trans n 0 1) (cadr key) 3)
           )
         )
       )
     )
     (if (eq (car key) 3)
       (progn
         (princ "\nSélectionner la colonne de cablage comme passage obligé: ")
         (while (not (setq js_cl (ssget "_+.:E:S" '((0 . "LWPOLYLINE"))))))
         (setq obj_vlax (vlax-ename->vla-object (ssname js_cl 0)) pr -1 lst_pt nil)
         (repeat (if (zerop (vlax-get obj_vlax 'Closed)) (1+ (fix (vlax-curve-getEndParam obj_vlax))) (fix (vlax-curve-getEndParam obj_vlax)))
           (setq
             pt (vlax-curve-GetPointAtParam obj_vlax (setq pr (1+ pr)))
             lst_pt (cons pt lst_pt)
           )
         )
         (if (< (distance (car lst_pt) (trans (cadr key) 1 0)) (distance (last lst_pt) (trans (cadr key) 1 0)))
           (setq lst_pt (reverse lst_pt))
         )
         (foreach n l_pt
           (setq pt_cl (vlax-curve-getClosestPointTo obj_vlax n))
           (command "_.pline" "_none" (trans n 0 1) "_none" (trans pt_cl 0 1))
           (foreach el lst_pt
             (if (<= (distance el (trans (cadr key) 1 0)) (distance pt_cl (trans (cadr key) 1 0)))
               (command "_none" (trans el 0 1))
             )
           )
           (command "_none" (cadr key) "")
         )
       )
     )
     (redraw)
   )
 )
 (prin1)
)

KSJ77 · le 10 décembre 2014

Merci @bonuscad ;)

Je vais essayer de le comprendre avant de l'utiliser

KSJ77 · le 10 décembre 2014

...essayes le sous cette forme. Mais je n'irais pas plus loin!

je comprends tout a fait

KSJ77 · le 24 décembre 2014

J'ai complété le lisp afin de pouvoir integrer les longueurs des polylines dans des attributs.

Cependant je suis obligé de sélectionner chaque polyligne et chaques attribut, es ce qu'il y aurait une autre méthode pour réduire le nombre d'opérations

Ensuite je n'arrive pas à rajouter dans le filtre de sélection, une sélection par nom de block.

(defun l-coor2l-pt (lst flag / )
 (if lst
   (cons
     (list
       (car lst)
       (cadr lst)
       (if flag
         (+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst))
         (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
       )
     )
     (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
   )
 )
)
(defun c:CABLECDC ( / js dxf_cod mod_sel n lremov ename l_pt l_pr key js_cl obj_vlax pr lst_pt pt pt_cl atent attobj ent leng obj)
 (princ "\nChoix d'un objet modèle pour le filtrage: ")
 (while
   (null
     (setq js
       (ssget "_+.:E:S"
         (list
           '(0 . "*LINE,POINT,ARC,CIRCLE,ELLIPSE,INSERT") ; <--filtre de selection que je n'arrive pas à modifier
           (cons 67 (if (eq (getvar "CVPORT") 1) 1 0))
           (cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model"))
         )
       )
     )
   )
   (princ "\nCe n'est pas un objet valable pour cette fonction!")
 )
 (vl-load-com)
 (setq dxf_cod (entget (ssname js 0)))
 (foreach m (foreach n dxf_cod (if (not (member (car n) '(0 67 410 8 6 62 48 420 70))) (setq lremov (cons (car n) lremov))))
   (setq dxf_cod (vl-remove (assoc m dxf_cod) dxf_cod))
 )
 (initget "Unique Tout Manuel _Single All Manual")
 (if (eq (setq mod_sel (getkword "\nMode de sélection filtrée, choix [unique/Tout/Manuel]<Manuel>: ")) "Single")
   (setq n -1)
   (if (eq mod_sel "All")
       (setq js (ssget "_X" dxf_cod) n -1)
       (setq js (ssget dxf_cod) n -1)
   )
 )
 (repeat (sslength js)
   (setq ename (vlax-ename->vla-object (ssname js (setq n (1+ n)))))
   (setq l_pr (list 'StartPoint 'EndPoint 'Center 'InsertionPoint 'Coordinates 'FitPoints))
   (foreach n l_pr
     (if (vlax-property-available-p ename n)
       (setq l_pt
         (if (or (eq n 'Coordinates) (eq n 'FitPoints))
           (append
             (if (eq (vla-get-ObjectName ename) "AcDbPolyline")
               (l-coor2l-pt (vlax-get ename n) nil)
               (if (and (eq n 'FitPoints) (zerop (vlax-get ename 'FitTolerance)))
                 (l-coor2l-pt (vlax-get ename 'ControlPoints) T)
                 (l-coor2l-pt (vlax-get ename n) T)
               )
             )
             l_pt
           )
           (cons (vlax-get ename n) l_pt)
         )
       )
     )
   )
 )
 (cond
   (l_pt
     (while (and (setq key (grread T 4 0)) (/= (car key) 3))
       (redraw)
       (cond
         ((eq (car key) 5)
           (foreach n l_pt
             (grdraw (trans n 0 1) (cadr key) 3)
           )
         )
       )
     )
     (if (eq (car key) 3)
       (progn
         (princ "\nSélectionner la colonne de cablage comme passage obligé: ")
         (while (not (setq js_cl (ssget "_+.:E:S" '((0 . "LWPOLYLINE"))))))
         (setq obj_vlax (vlax-ename->vla-object (ssname js_cl 0)) pr -1 lst_pt nil)
         (repeat (if (zerop (vlax-get obj_vlax 'Closed)) (1+ (fix (vlax-curve-getEndParam obj_vlax))) (fix (vlax-curve-getEndParam obj_vlax)))
           (setq
             pt (vlax-curve-GetPointAtParam obj_vlax (setq pr (1+ pr)))
             lst_pt (cons pt lst_pt)
           )
         )
         (if (< (distance (car lst_pt) (trans (cadr key) 1 0)) (distance (last lst_pt) (trans (cadr key) 1 0)))
           (setq lst_pt (reverse lst_pt))
         )
         (foreach n l_pt
           (setq pt_cl (vlax-curve-getClosestPointTo obj_vlax n))
           (command "_.pline" "_none" (trans n 0 1) "_none" (trans pt_cl 0 1))
           (foreach el lst_pt
             (if (<= (distance el (trans (cadr key) 1 0)) (distance pt_cl (trans (cadr key) 1 0)))
               (command "_none" (trans el 0 1))
             )
           )
           (command "_none" (cadr key) "")
         )
       )
     )
     (redraw)
   )
 )
(vl-load-com)
     (while
(setq ent
       (entsel "\nSelect Polyline (or press eEnter to Exit): "))
 (setq obj (vlax-ename->vla-object (car ent)))
 (setq leng (rtos
       (vlax-get-property obj "Length")
       2
       3      ; <--precison 3 decimals
       )
       )
 (if
   (setq atent
   (nentsel "\nSelect Attribute: "))
    (progn
      (setq attobj (vlax-ename->vla-object (car atent)))
      (vlax-put-property attobj "TextString" leng)
      )
    )
 )
 (princ)
)

Merci pour ceux qui pourront m'aider, je débute ;)

Et bonnes fêtes de fin d'année à tous

KSJ77 · le 29 décembre 2014

Bon j'avance petit à petit sur mon lisp

J'ai réussi à faire un filtre par sélection de type de Bloc et j'ai modifié la fin du Lisp pour mettre les longueurs dans des attributs mais sous forme de champs (extrait d'un lisp de Lee Mac)

(defun l-coor2l-pt (lst flag / )
 (if lst
   (cons
     (list
       (car lst)
       (cadr lst)
       (if flag
         (+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst))
         (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
       )
     )
     (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
   )
 )
)
(defun c:CABLECDC2 ( / js dxf_cod mod_sel n lremov ename l_pt l_pr key js_cl obj_vlax pr lst_pt pt pt_cl *error* tables doc spc p s q ExitFlag e)
(setq e (entsel "\nFiltre de Sélection par Nom de Bloc: "))
(if e (setq js (ssget "_X" (list(cons 2 (cdr (assoc 2 (entget (car e)))))(cons 0 "INSERT")))))
 (vl-load-com)
 (setq dxf_cod (entget (ssname js 0)))
 (foreach m (foreach n dxf_cod (if (not (member (car n) '(0 2 ))) (setq lremov (cons (car n) lremov))))
   (setq dxf_cod (vl-remove (assoc m dxf_cod) dxf_cod))
 )
 (initget "Unique Tout Manuel _Single All Manual")
 (if (eq (setq mod_sel (getkword "\nMode de sélection filtrée, choix [unique/Tout/Manuel]<Manuel>: ")) "Single")
   (setq n -1)
   (if (eq mod_sel "All")
       (setq js (ssget "_X" dxf_cod) n -1)
       (setq js (ssget dxf_cod) n -1)
   )
 )
 (repeat (sslength js)
   (setq ename (vlax-ename->vla-object (ssname js (setq n (1+ n)))))
   (setq l_pr (list 'StartPoint 'EndPoint 'Center 'InsertionPoint 'Coordinates 'FitPoints))
   (foreach n l_pr
     (if (vlax-property-available-p ename n)
       (setq l_pt
         (if (or (eq n 'Coordinates) (eq n 'FitPoints))
           (append
             (if (eq (vla-get-ObjectName ename) "AcDbPolyline")
               (l-coor2l-pt (vlax-get ename n) nil)
               (if (and (eq n 'FitPoints) (zerop (vlax-get ename 'FitTolerance)))
                 (l-coor2l-pt (vlax-get ename 'ControlPoints) T)
                 (l-coor2l-pt (vlax-get ename n) T)
               )
             )
             l_pt
           )
           (cons (vlax-get ename n) l_pt)
         )
       )
     )
   )
 )
 (cond
   (l_pt
     (while (and (setq key (grread T 4 0)) (/= (car key) 3))
       (redraw)
       (cond
         ((eq (car key) 5)
           (foreach n l_pt
             (grdraw (trans n 0 1) (cadr key) 3)
           )
         )
       )
     )
     (if (eq (car key) 3)
       (progn
         (princ "\nSélectionner le Chemin de câble (polyligne) comme passage obligé: ")
         (while (not (setq js_cl (ssget "_+.:E:S" '((0 . "LWPOLYLINE"))))))
         (setq obj_vlax (vlax-ename->vla-object (ssname js_cl 0)) pr -1 lst_pt nil)
         (repeat (if (zerop (vlax-get obj_vlax 'Closed)) (1+ (fix (vlax-curve-getEndParam obj_vlax))) (fix (vlax-curve-getEndParam obj_vlax)))
           (setq
             pt (vlax-curve-GetPointAtParam obj_vlax (setq pr (1+ pr)))
             lst_pt (cons pt lst_pt)
           )
         )
         (if (< (distance (car lst_pt) (trans (cadr key) 1 0)) (distance (last lst_pt) (trans (cadr key) 1 0)))
           (setq lst_pt (reverse lst_pt))
         )
         (foreach n l_pt
           (setq pt_cl (vlax-curve-getClosestPointTo obj_vlax n))
           (command "_.pline" "_none" (trans n 0 1) "_none" (trans pt_cl 0 1))
           (foreach el lst_pt
             (if (<= (distance el (trans (cadr key) 1 0)) (distance pt_cl (trans (cadr key) 1 0)))
               (command "_none" (trans el 0 1))
             )
           )
           (command "_none" (cadr key) "")
         )
       )
     )
     (redraw)
   )
 )
 (vl-load-com)
     (while
 (defun *error* ( msg )
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )

 (setq tables (LM:ss->vla (ssget "_X" '((0 . "ACAD_TABLE")))))

 (LM:ActiveSpace 'doc 'spc)   

 (cond
   (
     (setq p
       (LM:Selectif
         (lambda ( x )
           (vlax-property-available-p
             (vlax-ename->vla-object x) 'Length
           )
         )
         "\nMétré longeur, Selectionner cable: " nil
       )
     )
     (setq s
       (strcat "%<\\AcObjProp Object(%<\\_ObjId "
         (LM:GetObjectID doc (vlax-ename->vla-object p)) ">%).Length \\f \"%lu6\">%"
       )
     )         
     (while
       (progn
         (or ExitFlag
           (progn
             (initget "Point")
             (setq p (nentsel "\nSelect Text, MText or Attribute for Result [Point] <Exit> : "))
           )
         )
        
         (cond
           (
             ExitFlag nil
           )
           (
             (vl-consp p)
           
             (if (wcmatch (cdr (assoc 0 (entget (car p)))) "ATTRIB,*TEXT")
               (vla-put-TextString (vlax-ename->vla-object (car p)) s)
               (princ "\n** Object Must be Text, MText or Attribute **")
             )
           )
         )
       )
     )
   )
 )
 (vla-regen doc AcActiveViewport)
 (princ)
)
)  

(defun LM:ActiveSpace ( *doc *spc )
 (set *spc
   (if
     (or
       (eq AcModelSpace
         (vla-get-ActiveSpace
           (set *doc
             (vla-get-ActiveDocument
               (vlax-get-acad-object)
             )
           )
         )
       )
       (eq :vlax-true (vla-get-MSpace (eval *doc)))
     )
     (vla-get-ModelSpace (eval *doc))
     (vla-get-PaperSpace (eval *doc))
   )
 )
)

(defun LM:Selectif ( foo str nest / e )
   (while
   (progn
     (setq e (car ((if nest nentsel entsel) str)))
     
     (cond
       (
         (eq 'ENAME (type e))

         (if (not (foo e)) (princ "\n** Invalid Object Selected **"))
       )
     )
   )
 )
 e
)


(defun LM:GetObjectID ( doc obj )
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false)
   (itoa (vla-get-Objectid obj))
 )
)


(defun LM:ss->vla ( ss )
  (if ss
   (
     (lambda ( i / e l )
       (while (setq e (ssname ss (setq i (1+ i))))
         (setq l (cons (vlax-ename->vla-object e) l))
       )
       l
     )
     -1
   )
 )
)

Maintenant reste à savoir s'il est possible d'extraire automatiquement la longueur de chaque polyligne vers un attribut du bloc attaché à cette dernière.

Le résultat serait comme ceci (il s'agit d'un montage vidéo):

http://img4.hostingpics.net/pics/623817lisp2.gif

De plus j'ai essayé de modifier la ligne suivante pour pouvoir sélectionner plusieurs passages obligés

          (princ "\nSélectionner le Chemin de câble (polyligne) comme passage obligé: ")
         (while (not (setq js_cl (ssget "_+.:E:S" '((0 . "LWPOLYLINE"))))))

par

          (princ "\nSélectionner le Chemin de câble (polyligne) comme passage obligé: ")
         (while (not (setq js_cl (ssget "_+.:E" '((0 . "LWPOLYLINE"))))))

mais sans succès,une seule polyligne est pris en compte, quelqu'un aurait la solution?

KSJ77 · le 2 janvier 2015

Un membre de Cadtutor m'a filé un coup de main voici le LISP que j'ai essayé de retrvailler mais il n'est pas encore parfait :

- je voudrais ajouter au filtre de sélection un filtre par nom d'étiquette de bloc "LONGUEUR"

est-ce que la fonction conditionnelle " (if (= (vla-get-tagstring X) "LONGUEUR") peut être rajouté au filtre de sélection?

- je m'aperçois que si des blocs sont semi-supperposé la fonction "vla-put-Textstring" ne marche pas ....

(defun l-coor2l-pt (lst flag / )
 (if lst
   (cons
     (list
       (car lst)
       (cadr lst)
       (if flag
         (+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst))
         (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
       )
     )
     (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
   )
 )
)
(defun c:CABLECDC2 ( / js dxf_cod mod_sel n lremov ename l_pt l_pr key js_cl obj_vlax pr lst_pt pt pt_cl e ans attlst blk doc en_pt obj ss ss1 ss2 st_pt)
(setq e (entsel "\nFiltre de Sélection par Bloc (Attribut LONGUEUR) : "))
(if e (setq js (ssget "_X" (list(cons 2 (cdr (assoc 2 (entget (car e)))))(cons 0 "INSERT")))))
 (vl-load-com)
 (setq dxf_cod (entget (ssname js 0)))
 (foreach m (foreach n dxf_cod (if (not (member (car n) '(0 2 ))) (setq lremov (cons (car n) lremov))))
   (setq dxf_cod (vl-remove (assoc m dxf_cod) dxf_cod))
 )
 (initget "Unique Tout Manuel _Single All Manual")
 (if (eq (setq mod_sel (getkword "\nMode de sélection filtrée, choix [unique/Tout/Manuel]<Manuel>: ")) "Single")
   (setq n -1)
   (if (eq mod_sel "All")
       (setq js (ssget "_X" dxf_cod) n -1)
       (setq js (ssget dxf_cod) n -1)
   )
 )
 (repeat (sslength js)
   (setq ename (vlax-ename->vla-object (ssname js (setq n (1+ n)))))
   (setq l_pr (list 'StartPoint 'EndPoint 'Center 'InsertionPoint 'Coordinates 'FitPoints))
   (foreach n l_pr
     (if (vlax-property-available-p ename n)
       (setq l_pt
         (if (or (eq n 'Coordinates) (eq n 'FitPoints))
           (append
             (if (eq (vla-get-ObjectName ename) "AcDbPolyline")
               (l-coor2l-pt (vlax-get ename n) nil)
               (if (and (eq n 'FitPoints) (zerop (vlax-get ename 'FitTolerance)))
                 (l-coor2l-pt (vlax-get ename 'ControlPoints) T)
                 (l-coor2l-pt (vlax-get ename n) T)
               )
             )
             l_pt
           )
           (cons (vlax-get ename n) l_pt)
         )
       )
     )
   )
 )
 (cond
   (l_pt
     (while (and (setq key (grread T 4 0)) (/= (car key) 3))
       (redraw)
       (cond
         ((eq (car key) 5)
           (foreach n l_pt
             (grdraw (trans n 0 1) (cadr key) 3)
           )
         )
       )
     )
     (if (eq (car key) 3)
       (progn
         (princ "\nSélectionner le Chemin de câble (polyligne) comme passage obligé: ")
         (while (not (setq js_cl (ssget "_+.:E:S" '((0 . "LWPOLYLINE"))))))
         (setq obj_vlax (vlax-ename->vla-object (ssname js_cl 0)) pr -1 lst_pt nil)
         (repeat (if (zerop (vlax-get obj_vlax 'Closed)) (1+ (fix (vlax-curve-getEndParam obj_vlax))) (fix (vlax-curve-getEndParam obj_vlax)))
           (setq
             pt (vlax-curve-GetPointAtParam obj_vlax (setq pr (1+ pr)))
             lst_pt (cons pt lst_pt)
           )
         )
         (if (< (distance (car lst_pt) (trans (cadr key) 1 0)) (distance (last lst_pt) (trans (cadr key) 1 0)))
           (setq lst_pt (reverse lst_pt))
         )
         (foreach n l_pt
           (setq pt_cl (vlax-curve-getClosestPointTo obj_vlax n))
           (command "_.pline" "_none" (trans n 0 1) "_none" (trans pt_cl 0 1))
           (foreach el lst_pt
             (if (<= (distance el (trans (cadr key) 1 0)) (distance pt_cl (trans (cadr key) 1 0)))
               (command "_none" (trans el 0 1))
             )
           )
           (command "_none" (cadr key) "")
         )
       )
     )
     (redraw)
   )
 )
(vl-load-com)
(command "_.ucs" "_world")
 (princ "\nSélectionner les câbles (polylignes): ")
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (and (setq ss (ssget '((0 . "LWPOLYLINE"))))
          (not (initget 1 "Champs Text"))
          (setq ans (getkword "\nEnter an option [Champs/Text]: "))
     )
     (repeat (setq i (sslength ss))
     (setq obj   (vlax-ename->vla-object (ssname ss (setq i (1- i))))
           str   (rtos (vla-get-Length obj) 2 2)
           st_pt (trans (vlax-curve-getStartPoint obj) 0 1)
           en_pt (trans (vlax-curve-getEndPoint obj) 0 1)
     )
     (command "_.zoom" "_C" st_pt "")
     (setq ss1 (ssget "_C"
                      (polar st_pt (* 0.25 pi) 0.1)
                      (polar st_pt (* 1.25 pi) 0.1)
                      (list '(0 . "INSERT") (assoc 2 dxf_cod) '(66 . 1))
               )
     )
     (command "_.zoom" "_C" en_pt "")
     (setq ss2 (ssget "_C"
                      (polar en_pt (* 0.25 pi) 0.1)
                      (polar en_pt (* 1.25 pi) 0.1)
                      (list '(0 . "INSERT") (assoc 2 dxf_cod) '(66 . 1))
               )
     )
     (cond (ss1
            (setq blk (vlax-ename->vla-object (ssname ss1 0)))
           )
           (ss2
            (setq blk (vlax-ename->vla-object (ssname ss2 0)))
           )
     )
     (if blk
       (progn
         (setq attlst (vlax-invoke blk 'GetAttributes))
         (foreach a attlst
           (if (= (vla-get-TagString a) "LONGUEUR")
             (vla-put-TextString
               a
               (if (= ans "Champs")
                 (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                         (LM:GetObjectID doc obj)
                         ">%).Length \\f \"%lu2%pr1\">%"
                 )
                 str
               )
             )
           )
         )
       )
     )
   )
 )
 (command "UCS" "P")
 (vla-regen doc AcActiveViewport)
 (princ)
)

(defun LM:GetObjectID (doc obj)
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method
     (vla-get-Utility doc)
     'GetObjectIdString
     obj
     :vlax-false
   )
   (itoa (vla-get-Objectid obj))
 )
)

bonuscad · le 4 janvier 2015

Bonjour,

Pour la nouvelle année une petite suggestion!

Cela n'utilise pas un bloc, mais un champ dynamique pour produire tes étiquettes de longueur.

Cela ne fait pas coder beaucoup plus et c'est plus simple.

En partant du code que je t'ai donné précedemment:

(vl-load-com)
(defun l-coor2l-pt (lst flag / )
(if lst
	(cons
		(list
			(car lst)
			(cadr lst)
			(if flag
				(+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst))
				(if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
			)
		)
		(l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
	)
)
)
(defun c:CABLAGE_VDI ( / js AcDoc Space dxf_cod mod_sel n lremov ename l_pt l_pr key js_cl obj_vlax pr lst_pt pt nw_obj rtx pt_cl)
(princ "\nChoix d'un objet modèle pour le filtrage: ")
(while
	(null
		(setq js
			(ssget "_+.:E:S"
				(list
					'(0 . "*LINE,POINT,ARC,CIRCLE,ELLIPSE,INSERT")
					(cons 67 (if (eq (getvar "CVPORT") 1) 1 0))
					(cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model"))
				)
			)
		)
	)
	(princ "\nCe n'est pas un objet valable pour cette fonction!")
)
(setq
	AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
	Space
	(if (= 1 (getvar "CVPORT"))
		(vla-get-PaperSpace AcDoc)
		(vla-get-ModelSpace AcDoc)
	)
)
(cond
	((null (tblsearch "LAYER" "Label Longueur"))
		(vlax-put (vla-add (vla-get-layers AcDoc) "Label Longueur") 'color 96)
	)
)
(setq dxf_cod (entget (ssname js 0)))
(foreach m (foreach n dxf_cod (if (not (member (car n) '(0 67 410 8 6 62 48 420 70))) (setq lremov (cons (car n) lremov))))
	(setq dxf_cod (vl-remove (assoc m dxf_cod) dxf_cod))
)
(initget "Unique Tout Manuel _Single All Manual")
(if (eq (setq mod_sel (getkword "\nMode de sélection filtrée, choix [unique/Tout/Manuel]<Manuel>: ")) "Single")
	(setq n -1)
	(if (eq mod_sel "All")
			(setq js (ssget "_X" dxf_cod) n -1)
			(setq js (ssget dxf_cod) n -1)
	)
)
(repeat (sslength js)
	(setq ename (vlax-ename->vla-object (ssname js (setq n (1+ n)))))
	(setq l_pr (list 'StartPoint 'EndPoint 'Center 'InsertionPoint 'Coordinates 'FitPoints))
	(foreach n l_pr
		(if (vlax-property-available-p ename n)
			(setq l_pt
				(if (or (eq n 'Coordinates) (eq n 'FitPoints))
					(append
						(if (eq (vla-get-ObjectName ename) "AcDbPolyline")
							(l-coor2l-pt (vlax-get ename n) nil)
							(if (and (eq n 'FitPoints) (zerop (vlax-get ename 'FitTolerance)))
								(l-coor2l-pt (vlax-get ename 'ControlPoints) T)
								(l-coor2l-pt (vlax-get ename n) T)
							)
						)
						l_pt
					)
					(cons (vlax-get ename n) l_pt)
				)
			)
		)
	)
)
(cond
	(l_pt
		(while (and (setq key (grread T 4 0)) (/= (car key) 3))
			(redraw)
			(cond
				((eq (car key) 5)
					(foreach n l_pt
						(grdraw (trans n 0 1) (cadr key) 3)
					)
				)
			)
		)
		(if (eq (car key) 3)
			(progn
				(princ "\nSélectionner la colonne de cablage comme passage obligé: ")
				(while (not (setq js_cl (ssget "_+.:E:S" '((0 . "LWPOLYLINE"))))))
				(setq obj_vlax (vlax-ename->vla-object (ssname js_cl 0)) pr -1 lst_pt nil)
				(repeat (if (zerop (vlax-get obj_vlax 'Closed)) (1+ (fix (vlax-curve-getEndParam obj_vlax))) (fix (vlax-curve-getEndParam obj_vlax)))
					(setq
						pt (vlax-curve-GetPointAtParam obj_vlax (setq pr (1+ pr)))
						lst_pt (cons pt lst_pt)
					)
				)
				(if (< (distance (car lst_pt) (trans (cadr key) 1 0)) (distance (last lst_pt) (trans (cadr key) 1 0)))
					(setq lst_pt (reverse lst_pt))
				)
				(foreach n l_pt
					(setq pt_cl (vlax-curve-getClosestPointTo obj_vlax n))
					(command "_.pline" "_none" (trans n 0 1) "_none" (trans pt_cl 0 1))
					(foreach el lst_pt
						(if (<= (distance el (trans (cadr key) 1 0)) (distance pt_cl (trans (cadr key) 1 0)))
							(command "_none" (trans el 0 1))
						)
					)
					(command "_none" (cadr key) "")
					(setq nw_obj
						(vla-addMtext Space
							(vlax-3d-point (setq pt (polar (trans n 0 1) (+ (setq rtx (angle (trans n 0 1) (trans pt_cl 0 1))) (* pi 0.5)) (getvar "TEXTSIZE"))))
							0.0
							(strcat
								"{\\fArial|b0|i0|c0|p34;"
								"%<\\AcObjProp Object(%<\\_ObjId "
								(itoa (vla-get-ObjectID (vlax-ename->vla-object (entlast))))
								">%).Length \\f \"%lu2%pr2\">%"
							)
						)
					)
					(mapcar
						'(lambda (pr val)
							(vlax-put nw_obj pr val)
						)
						(list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation 'BackgroundFill)
						(list 5 (getvar "TEXTSIZE") 5 pt "Standard" "Label Longueur" rtx 0)
					)
				)
			)
		)
		(redraw)
	)
)
(prin1)
)

KSJ77 · le 4 janvier 2015

Bonjour,

Pour la nouvelle année une petite suggestion!
Cela n'utilise pas un bloc, mais un champ dynamique pour produire tes étiquettes de longueur.

Cela ne fait pas coder beaucoup plus et c'est plus simple.

Bonjour,

Tout d'abord merci pour ta suggestion, en effet plus simple et efficace! (plus de problèmes de valeurs superposées non remplies).

Mais je préfère travailler avec des blocs+attributs car une fois les longueurs remplies dans les blocs, j'utilise le merveilleux programme "eatt" de Gille afin de l'exporter vers Excel (j'aurais dû le préciser dans mon premier post).

Je vais donc continuer mon début d'apprentissage sur Autolisp/Vlisp afin d'améliorer et de corriger ce code mais toute aide est le bienvenu ;)

Connexion

Cablage en polyligne

Messages recommandés

KSJ77

bonuscad

KSJ77

KSJ77

KSJ77

KSJ77

KSJ77

bonuscad

KSJ77

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Forums

Naviguer

Activité

Information importante