Nuage de révision par 2 points

[zebulon_]

Bonjour,

 

le plus souvent, il suffirait de créer le nuage de révision à partir d'un rectangle (donc 2 points), ou d'un cercle (2 points aussi) ou d'une polyligne pas trop compliquée. De plus, les longueurs d'arc pourraient se déterminer automatiquement en fonction de la taille - de l'encombrement - du contour qui sert à générer le nuage. Par défaut, j'ai choisi le 10ème de l'encombrement du contour. Pour finir, ce serait bien que le nuage créé se mette sur un calque "REVCLOUD" (ou autre...)

 

En fait, je n'aime pas trop le concept du trajet à main levée : faut que j'arrête l'alcool... Souvent, la souris s'égare ou alors j'ai du mal à fermer le contour et ça donne juste une m... et il faut recommencer.

 

Au moins, avec à la base un rectangle, un cercle ou une polyligne (fermée ou non), c'est plus simple et, pendant le tracé d'une polyligne, on peut revenir en arrière si on s'est un peu égaré en cours de route.

 

(defun c:recrev (/ AcDoc Space FORME FAC ST MSG PT1 R lelem cmdsave TEMP old_clayer mycmdrev fac_ent get_msg_recrev calque)

 (vl-load-com)
 (setq AcDoc (vla-get-activeDocument (vlax-get-acad-object))
       Space (if (= (getvar "CVPORT") 1)
               (vla-get-PaperSpace AcDoc)
               (vla-get-ModelSpace AcDoc) 
             )
 )


;;;
;;; lancer une commande autocad

(defun mycmdrev (CMD PT / ETL LELEM RES OLDCMDECHO)
 (setq ETL (entlast))
 (setq OLDCMDECHO (getvar "CMDECHO"))
 (setvar "CMDECHO" 1)
 (command CMD PT)
 (while (not (zerop (getvar "cmdactive")))
   (command pause)
 )
 (setvar "CMDECHO" OLDCMDECHO)
 (setq LELEM nil)
 (if (not ETL) 
   (setq ETL (entnext))
   (setq ETL (entnext ETL))
 )
 (while ETL
   (setq LELEM (cons ETL LELEM))
   (setq ETL (entnext ETL))
 )
 (setq RES LELEM)
)


(defun fac_ent (e / util obj minpoint maxpoint)

 (setq util (vla-get-utility 
                  (vla-get-activedocument 
                       (vlax-get-acad-object))))

 (setq obj (vlax-ename->vla-object e))

 (vla-GetBoundingBox obj 'minpoint 'maxpoint)

 (distance
   (vlax-safearray->list minpoint)
   (vlax-safearray->list maxpoint)
 )
);defun


(defun get_msg_recrev (FORME)
 (cond
   ((= FORME "Rectangulaire")
     "\nSpécifiez le premier coin :"
   )
   ((= FORME "Circulaire")
     "\nSpécifiez le centre :"
   )
   ((= FORME "Polygonal")
     "\nSpécifiez le point de départ :" 
   )
 )
)

;;; créer un calque
(defun calque (NewLayer ColLayer TlLayer LwLayer / LtTable LayerTable aNewLayer)
 (if (not (tblsearch "LTYPE" TlLayer))  ;; charger le style de traits
   (progn
     (setq LtTable (vla-get-LineTypes AcDoc))
     (vla-load LtTable TlLayer "acadiso.lin")
   )
 )
 (setq LayerTable (vla-get-layers AcDoc))
 (if (not (tblsearch "LAYER" NewLayer))
   (progn  ;; créer le calque qui n'existe pas
     (setq aNewLayer (vla-add LayerTable NewLayer))
     (vla-put-color aNewLayer ColLayer)
     (vla-put-LineType aNewLayer TlLayer)
     (vla-put-LineWeight aNewLayer LwLayer)
   )
   (progn  ;; le calque existe -> le rendre disponible
     (setq aNewLayer (vla-item LayerTable NewLayer))
     (if (= (vla-get-Lock aNewLayer) ':vlax-true) 
       (vla-put-Lock aNewLayer :vlax-false)
     )
     (if (= (vla-get-Freeze aNewLayer) ':vlax-true)
       (progn
         (vla-put-Freeze aNewLayer :vlax-false)
         (vla-regen AcDoc acAllViewports)
       )
     )
     (if (= (vla-get-LayerOn aNewLayer) ':vlax-false)
       (vla-put-LayerOn aNewLayer :vlax-true)
     )
   )
 )
 (setvar "CLAYER" NewLayer)  ;; et le rendre actif
)


 (setq cmdsave (getvar "cmdecho"))
 (setvar "cmdecho" 0)

 (or (setq FORME (vlax-ldata-get "CADSYS" "FORME_RECREV"))
   (setq FORME "Rectangulaire")
 )
 (or (setq FAC (vlax-ldata-get "CADSYS" "FAC_RECREV"))
   (setq FAC 0.1)
 )
 (or (setq ST (vlax-ldata-get "CADSYS" "ST_RECREV"))
   (setq ST "Normal")
 )
 (setq MSG (get_msg_recrev FORME))

 (setq PT1 nil)

 (while (/= (type PT1) 'list) 
   (prompt (strcat "\nForme du nuage : " FORME "   Style : " ST "\nFacteur de densité : " (rtos FAC)))
   (initget "Rectangulaire Circulaire Polygonal Style Facteur")
   (or
     (setq PT1 (getpoint (strcat MSG " [Rectangulaire/Circulaire/Polygonal/Style/Facteur] <Facteur> : ")))
     (setq PT1 "Facteur")
   )
   (cond
     ((= PT1 "Facteur")
       (initget 6)  ;; pas de zéro ni de négatif
       (setq TEMP (getdist (strcat "\nNouveau facteur de densité (non nul et inférieur à 0.50)  <" (rtos FAC) "> : ")))
       (if TEMP
         (setq FAC (min TEMP 0.50))
       )
     )
     ((= PT1 "Style")
       (initget "Normal Calligraphie")
       (setq TEMP (getkword (strcat "\nSélectionner le style d'arc : [Normal Calligraphie] <" ST ">")))
       (if TEMP
         (setq ST TEMP)
       )
     )
     ((member PT1 '("Rectangulaire" "Circulaire" "Polygonal"))
       (setq FORME PT1)
       (setq MSG (get_msg_recrev FORME))
     )
   )
 ) 
 (cond
   ((= FORME "Rectangulaire")
     (setq lelem (mycmdrev "_RECTANG" PT1))
   )
   ((= FORME "Circulaire")
     (setq lelem (mycmdrev "_CIRCLE" PT1))
   )
   ((= FORME "Polygonal")
     (setq lelem (mycmdrev "_PLINE" PT1))
   )
 )

 (if lelem
   (progn
     (setq old_clayer (getvar "CLAYER"))
     (setq old_delobj (getvar "DELOBJ"))
     (setvar "DELOBJ" 3)  ;; Supprime toute la géométrie de définition
     (calque "REVCLOUD" 7 "Continuous" 18)
     (setq R (* (fac_ent (car lelem)) FAC))
     (command 
        "_revcloud" 
        "_s" (strcat "_" (substr ST 1 1))
        "_a" R R 
        "_o" (car lelem) 
        "_n"
      )  ;; dessine le nuage
     (vlax-ldata-put "CADSYS" "FORME_RECREV" FORME)
     (vlax-ldata-put "CADSYS" "FAC_RECREV" FAC)
     (vlax-ldata-put "CADSYS" "ST_RECREV" ST)
     (setvar "CLAYER" old_clayer)
     (setvar "DELOBJ" old_delobj)
   )
   (alert "Pas de contour créé")
 )
 (setvar "cmdecho" cmdsave)
 (princ)
)

 

Amicalement

Vincent

[grandss]

Salut,

 

Super ton Lisp, je l'ai adopté.

Un grand merci.

[zebulon_]

Bonjour,

 

en même temps, ce lisp n'aura pas une très grande longévité en tant que tel, compte tenu que la version 2016 (que je n'ai pas encore installée chez moi...) apporte une amélioration importante de ces nuages de révision. Et l'amélioration va, à certains égards, bien plus loin que le lisp , compte tenu que ces nouveaux REVCLOUD sont, d'après ce que j'ai pu voir dans les commentaires ici et là sur la toile, conçus comme des objets étirables par le biais de poignées. Avec 2016, on peut (enfin...) étirer un REVCLOUD comme on étire un rectangle ou une polyligne. Le nuage conserve la géométrie de l'objet qui a servi à le construire et on peut modifier le nuage en modifiant cet objet de base. Pour donner une image, cela ressemble un peu au fonctionnement d'une polyligne qu'on a transformé en sPline via Pedit.

 

Dès que j'aurai installé 2016, je me pencherai sur la question. Merci à ceux qui utilisent 2016 pour un éventuel retour d'expérience.

 

Amicalement

Vincent

[pierrevigneux]

Merci j'ai pris ma copie.

 

Bonne fin de journée!