Aller au contenu

Messages recommandés

Posté(e)

Je reviens sur un ancien sujet, sur le comptage des blocs dynamique et autres

Le code suivant est bon (de patrick), mais j'ai besoin de pouvoir selectionner une zone de comptage, et voir même compter dans une zone definie par une polyligne

 

merci

 

 

 (defun c:CT(/ js bllst ent CT)
(if (setq js (ssget "x" (list (cons 0 "INSERT"))))
(progn
(setq CT
(mapcar '(lambda (x)
(setq x (vlax-ename->vla-object x))
(if (vlax-property-available-p x 'EffectiveName)
(vla-get-EffectiveName x)
(vla-get-Name x)
)
)
(mapcar 'cadr (ssnamex js))
)
)
(foreach ent CT
(if (not (member ent (mapcar 'car bllst)))
(setq bllst (append bllst (list (cons ent (length (vl-remove-if-not '(lambda (x) (eq ent x)) CT))))))
)
)
;(mapcar '(lambda (x) (princ (strcat "\n" (itoa (cdr x)) " bloc(s) " (car x)))) bllst )
(mapcar '(lambda (x) (princ (strcat "\n" (car x) "  " (itoa (cdr x)) ))) bllst )
)
)
(princ)
)
(princ "\nCTT chargé. Tapez CT pour l'exécuter")
(princ)

Posté(e)

Salut

Quelque chose comme ça

 

(defun c:ct(/ bllst ent js lstbl nb)
 (if (setq js (ssget (list (cons 0 "INSERT"))))
   (progn
     (setq nb 0)
     (while (setq ent (ssname js nb))
       (setq ent (vlax-ename->vla-object ent))
       (if (not (vlax-property-available-p ent 'Path))
         (if (vlax-property-available-p ent 'EffectiveName)
           (setq lstbl (append lstbl (list (vla-get-EffectiveName ent))))
           (setq lstbl (append lstbl (list (vla-get-Name ent))))
         )
       )
       (setq nb (1+ nb))
     )
     (setq lstbl (acad_strlsort lstbl))
     (while (setq ent (car lstbl))
       (setq nb    (length lstbl)
             lstbl (vl-remove ent lstbl)
             bllst (append bllst (list (cons ent (- nb (length lstbl))))))
     )
     (mapcar '(lambda (x) (princ (strcat "\nIl y a " (itoa (cdr x)) " bloc(s) " (car x)))) bllst)
   )
 )
 (princ)
)


(princ "\nCTT.LSP chargé. Tapez CT pour l'exécuter")
(princ)

 

@+

Les Lisps de Patrick

Le but n'est pas toujours placé pour être atteint, mais pour servir de point de mire.

Joseph Joubert, 1754-1824

Posté(e)

Bien comme d'habitude.....

 

Juste une question, pourquoi ne retrouve ne pas ton travail en zone de téléchargement ?

car dans le cas suivant c'est ton code depuis le début, et cela dans le but de retrouver plus facilement les petit lisp qui nous rendent la vie plus facile.

 

c'est juste une idée..

  • 5 mois après...
Posté(e)

Bonjour,

je ne comprend pas pourquoi ça marche pas chez moi.

 

J'ai chargé cela :

 

(defun c:ct(/ bllst ent js lstbl nb)

(if (setq js (ssget (list (cons 0 "INSERT"))))

(progn

(setq nb 0)

(while (setq ent (ssname js nb))

(setq ent (vlax-ename->vla-object ent))

(if (not (vlax-property-available-p ent 'Path))

(if (vlax-property-available-p ent 'EffectiveName)

(setq lstbl (append lstbl (list (vla-get-EffectiveName ent))))

(setq lstbl (append lstbl (list (vla-get-Name ent))))

)

)

(setq nb (1+ nb))

)

(setq lstbl (acad_strlsort lstbl))

(while (setq ent (car lstbl))

(setq nb (length lstbl)

lstbl (vl-remove ent lstbl)

bllst (append bllst (list (cons ent (- nb (length lstbl))))))

)

(mapcar '(lambda (x) (princ (strcat "\nIl y a " (itoa (cdr x)) " bloc(s) " (car x)))) bllst)

)

)

(princ)

)

 

 

(princ "\nCTT.LSP chargé. Tapez CT pour l'exécuter")

(princ)

 

 

Mas je n'ai toujours pas le choix de prendre une polyligne comme zone de comptage.

 

Comment cela se fait ?

 

Merci de votre aide !

Posté(e)

Mas je n'ai toujours pas le choix de prendre une polyligne comme zone de comptage.

 

Pour utiliser un objet graphique comme fenêtre (ou capture) de sélection, il faut utiliser une routine qui récupère des sommets sur l'objet pour lees passer comme argument à une sélection polygonale ("_wp" ou "_cp").

Tu peux utiliser la routine SelbyObj et changer le début du LISP de ASTERIXII/Patrick_35 avec quelque chose du genre :

 

NOTA : Supprimer les espaces apès les "

 

(defun c:ct (/ opt obj bllst ent js lstbl nb)
 (initget "Objet Sélection Tous")
 (or
   (setq opt
   (getkword
     "\Choisir une option [Objet/Sélection/Tous] : "
   )
   )
   (setq opt "Sélection")
 )
 (cond
   ((= opt "Objet")
     (and
(setq obj (ssget "_:S:E"
		 (list
		   '(-4 . "			   '(0 . "CIRCLE")
		   '(-4 . "			   '(0 . "ELLIPSE")
		   '(41 . 0.0)
		   (cons 42 (* 2 pi))
		   '(-4 . "AND>")
		   '(-4 . "			   '(0 . "LWPOLYLINE")
		   '(-4 . "&")
		   '(70 . 1)
		   '(-4 . "AND>")
		   '(-4 . "OR>")
		 )
	  )
)
(setq js (SelbyObj (ssname obj 0) "Wp" '((0 . "INSERT")))) [color=#FF0000]; Remplacer "Wp" par "Cp" pour une capture[/color]
     )
   )
   ((= opt "Sélection")
    (setq js (ssget '((0 . "INSERT"))))
   )
   ((= opt "Tous")
    (setq js (ssget "_X" '((0 . "INSERT"))))
   )
 )
 (if js
   (progn
     (setq nb 0)
     (while (setq ent (ssname js nb))
(setq ent (vlax-ename->vla-object ent))
(if (not (vlax-property-available-p ent 'Path))
  (if (vlax-property-available-p ent 'EffectiveName)
    (setq
      lstbl (append lstbl (list (vla-get-EffectiveName ent)))
    )
    (setq lstbl (append lstbl (list (vla-get-Name ent))))
  )
)
(setq nb (1+ nb))
     )
     (setq lstbl (acad_strlsort lstbl))
     (while (setq ent (car lstbl))
(setq nb    (length lstbl)
      lstbl (vl-remove ent lstbl)
      bllst (append bllst (list (cons ent (- nb (length lstbl)))))
)
     )
     (mapcar
'(lambda (x)
   (princ
     (strcat "\nIl y a " (itoa (cdr x)) " bloc(s) " (car x))
   )
 )
bllst
     )
   )
 )
 (princ)
) 

;;; SelByObj -Gilles Chanteau- 06/10/06
;;; Crée un jeu de sélection avec tous les objets contenus ou
;;; capturés, dans la vue courante, par l'objet sélectionné
;;; (cercle, ellipse, polyligne fermée).
;;; Arguments :
;;; - un nom d'entité (ename)
;;; - un mode de sélection (Cp ou Wp)
;;; - un filtre de sélection ou nil

(defun SelByObj (ent opt fltr / obj dist n lst prec dist p_lst)
(vl-load-com)
(setq obj (vlax-ename->vla-object ent))
(cond
((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
(setq dist (/ (vlax-curve-getDistAtParam
obj
(vlax-curve-getEndParam obj)
)
50
)
n 0
)
(repeat 50
(setq
lst
(cons
(trans
(vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
0
1
)
lst
)
)
)
)
(T
(setq p_lst (vl-remove-if-not
'(lambda (x)
(or (= (car x) 10)
(= (car x) 42)
)
)
(entget ent)
)
)
(while p_lst
(setq
lst (append
lst
(list (trans (append (cdr (assoc 10 p_lst))
(list (cdr (assoc 38 (entget ent))))
)
ent
1
)
)
)
)
(if (/= 0 (cdadr p_lst))
(progn
(setq prec (1+ (fix (* 50 (abs (cdadr p_lst)))))
dist (/ (- (if (cdaddr p_lst)
(vlax-curve-getDistAtPoint
obj
(trans (cdaddr p_lst) ent 0)
)
(vlax-curve-getDistAtParam
obj
(vlax-curve-getEndParam obj)
)
)
(vlax-curve-getDistAtPoint
obj
(trans (cdar p_lst) ent 0)
)
)
prec
)
n 0
)
(repeat (1- prec)
(setq
lst (append
lst
(list
(trans
(vlax-curve-getPointAtDist
obj
(+ (vlax-curve-getDistAtPoint
obj
(trans (cdar p_lst) ent 0)
)
(* dist (setq n (1+ n)))
)
)
0
1
)
)
)
)
)
)
)
(setq p_lst (cddr p_lst))
)
)
)
(ssget (strcat "_" opt) lst fltr)
)

 

[Edité le 17/7/2007 par (gile)]

Gilles Chanteau - gileCAD - GitHub
Développements sur mesure pour AutoCAD

Posté(e)

Ok merci beaucoup !

 

Par contre j'ai remarqué un gros bug (qui vient d'autocad à mon avis).

 

Quand je selectionne ma polyligne avec un zoom tout, alors, le lisp me comptabilise bien tous les blocs.

 

Par contre, si je zoom sur une partie de l'écran (donc je ne vois plus ma polyligne entièrement), le lisp prend en considération l'affichage écran + polilygne. (c'est à dire que les limites de mon écran (ce que je vois) correspond à ce moment là à ma polyligne !!!!

 

Pour palier à ce problème, comment pourrait-on rajouter un zoom objet sur la polyligne (dans le lisp) afin que avant le traitement de comptage, le lisp positionne l'affichage écran sur la totalité de la polyligne ?

 

En théorie il suffirait de rajouter _zoom _o

mais où, ça je ne sais pas !

 

Merci de votre aide.

 

[Edité le 19/7/2007 par funkkybebel]

Posté(e)

Salut,

 

eh oui, AutocAD ne permet pas une sélection par fenêtre, capture, polygone ou trajet hors de la fenêtre courante.

 

Voilà une version de SelByObj qui le fait (zoom étendu avant la sélection et zoom précédent ensuite). Il suffit de remplacer la routine selbyOj que tu avais par celle-ci.

 

;;; SelByObj -Gilles Chanteau- 06/10/06
;;; Crée un jeu de sélection avec tous les objets contenus ou  capturés,
;;; dans la vue courante, par un objet (cercle, ellipse, polyligne fermée)
;;; Arguments :
;;; - ent : un objet (ename ou vla-object) 
;;; - opt : un mode de sélection (Cp ou Wp)
;;; - fltr : un filtre de sélection (liste) ou nil
;;;
;;; modifié le 19/07/07 : fonctionne avec les objets hors fenêtre

(defun SelByObj	(ent opt fltr / obj dist n lst prec dist p_lst ss)
 (vl-load-com)
 (if (= (type ent) 'ENAME)
   (setq obj (vlax-ename->vla-object ent))
   (setq obj ent
  ent (vlax-vla-object->ename ent)
   )
 )
 (cond
   ((member (vla-get-ObjectName obj) '("AcDbCircle" "AcDbEllipse"))
    (setq dist	(/ (vlax-curve-getDistAtParam
	     obj
	     (vlax-curve-getEndParam obj)
	   )
	   50
	)
   n	0
    )
    (repeat 50
      (setq
 lst
  (cons
    (trans
      (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
      0
      1
    )
    lst
  )
      )
    )
   )
   ((and (= (vla-get-ObjectName obj) "AcDbPolyline")
  (= (vla-get-Closed obj) :vlax-true)
  )
    (setq p_lst (vl-remove-if-not
	   '(lambda (x)
	      (or (= (car x) 10)
		  (= (car x) 42)
	      )
	    )
	   (entget ent)
	 )
    )
    (while p_lst
      (setq
 lst
  (cons
    (trans (append (cdr (assoc 10 p_lst))
			 (list (cdr (assoc 38 (entget ent))))
		 )
		 ent
		 1
    )
    lst
  )
      )
      (if (/= 0 (cdadr p_lst))
 (progn
   (setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
	 dist (/ (- (if	(cdaddr p_lst)
		      (vlax-curve-getDistAtPoint
			obj
			(trans (cdaddr p_lst) ent 0)
		      )
		      (vlax-curve-getDistAtParam
			obj
			(vlax-curve-getEndParam obj)
		      )
		    )
		    (vlax-curve-getDistAtPoint
		      obj
		      (trans (cdar p_lst) ent 0)
		    )
		 )
		 prec
	      )
	 n    0
   )
   (repeat (1- prec)
     (setq
       lst (cons
	     (trans
		 (vlax-curve-getPointAtDist
		   obj
		   (+ (vlax-curve-getDistAtPoint
			obj
			(trans (cdar p_lst) ent 0)
		      )
		      (* dist (setq n (1+ n)))
		   )
		 )
		 0
		 1
	       )
	     lst
	   )
     )
   )
 )
      )
      (setq p_lst (cddr p_lst))
    )
   )
 )
 (cond
   (lst
    (vla-ZoomExtents (vlax-get-acad-object))
    (setq ss (ssget (strcat "_" opt) lst fltr))
    (vla-ZoomPrevious (vlax-get-acad-object))
    ss
   )
 )
)

;;; SSOC pour sélectionner tous les objets capturés, suivant
;;; la vue, par le cercle, l'ellipse ou la polyligne.

(defun c:ssoc (/ ss opt)
 (and
   (or
     (and
(setq ss (cadr (ssgetfirst)))
(= 1 (sslength ss))
     )
     (and
(sssetfirst nil nil)
(setq ss (ssget	"_:S:E"
		(list
		  '(-4 . "			  '(0 . "CIRCLE")
		  '(-4 . "			  '(0 . "ELLIPSE")
		  '(41 . 0.0)
		  (cons 42 (* 2 pi))
		  '(-4 . "AND>")
		  '(-4 . "			  '(0 . "LWPOLYLINE")
		  '(-4 . "&")
		  '(70 . 1)
		  '(-4 . "AND>")
		  '(-4 . "OR>")
		)
	 )
)
     )
   )
   (sssetfirst
     nil
     (ssdel (ssname ss 0) (SelByObj (ssname ss 0) "Cp" nil))
   )
 )
 (princ)
)

;;; SSOF pour sélectionner tous les objets contenus, suivant
;;; la vue, dans le cercle, l'ellipse ou la polyligne.

(defun c:ssof (/ ss opt)
 (and
   (or
     (and
(setq ss (cadr (ssgetfirst)))
(= 1 (sslength ss))
     )
     (and
(sssetfirst nil nil)
(setq ss (ssget	"_:S:E"
		(list
		  '(-4 . "			  '(0 . "CIRCLE")
		  '(-4 . "			  '(0 . "ELLIPSE")
		  '(41 . 0.0)
		  (cons 42 (* 2 pi))
		  '(-4 . "AND>")
		  '(-4 . "			  '(0 . "LWPOLYLINE")
		  '(-4 . "&")
		  '(70 . 1)
		  '(-4 . "AND>")
		  '(-4 . "OR>")
		)
	 )
)
     )
   )
   (sssetfirst
     nil
     (SelByObj (ssname ss 0) "Wp" nil)
   )
 )
 (princ)
) 

Gilles Chanteau - gileCAD - GitHub
Développements sur mesure pour AutoCAD

Posté(e)

Bonjour,

désolé pour le temps de réponse, et je te remercie.

Par contre ça ne marche pas et en plus je me suis trompé de programme.

 

Est-il possible d'ajouter la particularité de faire un zoom OBJET (uniquement sur la polyligne et pas sur tout le dessin) avant de procéder au comptage sur le lisp suivant (cnt-blk.lsp) :

 

 
(defun c:cnt-blk (/ obj ss n bl nom lst str file)
(vl-load-com)
(prompt "\nSélectionnez les blocs ou < Objet >: ")
(if (not (setq ss (ssget '((0 . "INSERT")))))
(if
(setq
obj
(car
(entsel "\nSélectionnz l'objet délimitant la sélection: ")
)
)
(if (member (cdr (assoc 0 (entget obj)))
'("CIRCLE" "ELLIPSE" "LWPOLYLINE")
)
(setq ss (SelByObj obj "WP" '((0 . "INSERT"))))
(princ "\nEntité non valide.")
)
(princ "\nAucune entité sélectionnée.")
)
)
(if ss
(progn
(setq n (sslength ss))
(setq str (strcat "\n" (itoa n) " blocs dans la sélection\n")
)
(repeat n
(setq bl (vlax-ename->vla-object (ssname ss (setq n (1- n))))
nom (if (vlax-property-available-p bl 'EffectiveName)
(vla-get-EffectiveName bl)
(vla-get-Name bl)
)
lst (if (assoc nom lst)
(subst (cons nom (1+ (cdr (assoc nom lst))))
(assoc nom lst)
lst
)
(cons (cons nom 1) lst)
)
)
)
(setq str
(apply 'strcat
(cons str
(mapcar
'(lambda (x)
(strcat (car x)
"\t"
(itoa (cdr x))
"\n"
)
)
lst
)
)
)
)
(textscr)
(princ str)
(initget "Oui Non")
(if
(= (getkword
"\nEnregistrer dans un fichier ? [Oui/Non] < Non >: "
)
"Oui"
)
(progn
(setq
file
(open
(getfiled "Créez ou sélectionnez un fichier"
""
"xls"
1
)
"a"
)
)
(princ str file)
(close file)
)
)
(graphscr)
)
(princ "\nAucune entité sélectionnée.")
)
(princ)
)

 

 

Merci de votre aide à tous...

Posté(e)

Salut,

Par contre ça ne marche pas

Curieux...

Avec la nouvelle version de SelByObj (zoom étendu avant la sélection) ça fonctionne très bien chez moi.

 

Est-il possible d'ajouter la particularité de faire un zoom OBJET

Si tu pense qu'un zoom objet à la place du zoom étendu fonctionnera mieux, voici une nouvelle version de SelByObj qui fait un zoom sur l'emprise de l'objet sélectionné selon la vue courante.

Ou encore, utiliser la routine ZoomObject :

(ZoomObject (list obj)) à la place du (vla-zoomExtents (vlax-get-acad-object))

 

;;; SelByObj -Gilles Chanteau- 06/10/06
;;; Crée un jeu de sélection avec tous les objets contenus ou  capturés,
;;; dans la vue courante, par un objet (cercle, ellipse, polyligne fermée)
;;; Arguments :
;;; - ent : un objet (ename ou vla-object) 
;;; - opt : un mode de sélection (Cp ou Wp)
;;; - fltr : un filtre de sélection (liste) ou nil
;;;
;;; modifié le 26/07/07 : fonctionne avec les objets hors fenêtre (zoom objet)

(defun SelByObj	(ent   opt   fltr  /	 obj   dist  n	   lst	 prec
	 dist  p_lst ss	   app	 doc   vdir  plst  minpt maxpt
	)
 (vl-load-com)
 (if (= (type ent) 'ENAME)
   (setq obj (vlax-ename->vla-object ent))
   (setq obj ent
  ent (vlax-vla-object->ename ent)
   )
 )
 (cond
   ((member (vla-get-ObjectName obj)
     '("AcDbCircle" "AcDbEllipse")
    )
    (setq dist	(/ (vlax-curve-getDistAtParam
	     obj
	     (vlax-curve-getEndParam obj)
	   )
	   50
	)
   n	0
    )
    (repeat 50
      (setq
 lst
  (cons
    (trans
      (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
      0
      1
    )
    lst
  )
      )
    )
   )
   ((and (= (vla-get-ObjectName obj) "AcDbPolyline")
  (= (vla-get-Closed obj) :vlax-true)
    )
    (setq p_lst (vl-remove-if-not
	   '(lambda (x)
	      (or (= (car x) 10)
		  (= (car x) 42)
	      )
	    )
	   (entget ent)
	 )
    )
    (while p_lst
      (setq
 lst
  (cons
    (trans (append (cdr (assoc 10 p_lst))
		   (list (cdr (assoc 38 (entget ent))))
	   )
	   ent
	   1
    )
    lst
  )
      )
      (if (/= 0 (cdadr p_lst))
 (progn
   (setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
	 dist (/ (- (if	(cdaddr p_lst)
		      (vlax-curve-getDistAtPoint
			obj
			(trans (cdaddr p_lst) ent 0)
		      )
		      (vlax-curve-getDistAtParam
			obj
			(vlax-curve-getEndParam obj)
		      )
		    )
		    (vlax-curve-getDistAtPoint
		      obj
		      (trans (cdar p_lst) ent 0)
		    )
		 )
		 prec
	      )
	 n    0
   )
   (repeat (1- prec)
     (setq
       lst (cons
	     (trans
	       (vlax-curve-getPointAtDist
		 obj
		 (+ (vlax-curve-getDistAtPoint
		      obj
		      (trans (cdar p_lst) ent 0)
		    )
		    (* dist (setq n (1+ n)))
		 )
	       )
	       0
	       1
	     )
	     lst
	   )
     )
   )
 )
      )
      (setq p_lst (cddr p_lst))
    )
   )
 )
 (cond
   (lst
    (setq app (vlax-get-acad-object)
   doc (vla-get-ActiveDocument app)
    )
    (vla-delete (vla-get-ActiveViewport doc))
    (setq vdir	 (vlax-get (vla-get-ActiveViewport doc) 'Direction)
   plst	 (mapcar '(lambda (x)
		    (trans x 1 vdir)
		  )
		 lst
	 )
   minpt (apply 'mapcar (cons 'min plst))
   maxpt (apply 'mapcar (cons 'max plst))
    )
    (vla-ZoomWindow
      app
      (vlax-3d-point (trans minpt vdir 0))
      (vlax-3d-point (trans maxpt vdir 0))
    )
    (setq ss (ssget (strcat "_" opt) lst fltr))
    (vla-ZoomPrevious (vlax-get-acad-object))
    ss
   )
 )
)

Gilles Chanteau - gileCAD - GitHub
Développements sur mesure pour AutoCAD

Posté(e)

Merci,

mais est-il possible de l'integrer dans l'autre programme cité en réponse n°10 ?

 

Merci, mais je suis une vraie quiche en lisp (j'ai bien essayé de recherché les lignes qui permettent de faire un zoom objet pour les repositionner dans l'autre programme mais je n'y vois que du feu)

Posté(e)

Salut,

 

J'ai modifié (ci-dessous) cnt-blk pour faire un zoom objet sur l'objet sélectionné avant de lancer SelByObj.

 

Tel quel, la vue précedente est restituée ensuite, si tu veux rester en zoom objet, supprime la ligne :

[surligneur](vla-ZoomPrevious (vlax-get-acad-object)) [/surligneur]

 

J'ai aussi joint avec toutes les routines nécessaire, la version originale de SelByObj pour eviter des zooms inutiles.

 

(defun c:cnt-blk (/ obj ss n bl nom lst str file)
 (vl-load-com)
 (prompt "\nSélectionnez les blocs ou : ")
 (if (not (setq ss (ssget '((0 . "INSERT")))))
   (if
     (setq
obj
 (car
   (entsel "\nSélectionnez l'objet délimitant la sélection: ")
 )
     )
      (if (member (cdr (assoc 0 (entget obj)))
	   '("CIRCLE" "ELLIPSE" "LWPOLYLINE")
   )
 (progn
   (ZoomObject (list (vlax-ename->vla-object obj)))
   (setq ss (SelByObj obj "WP" '((0 . "INSERT"))))
   [surligneur](vla-ZoomPrevious (vlax-get-acad-object))[/surligneur]
 )
 (princ "\nEntité non valide.")
      )
      (princ "\nAucune entité sélectionnée.")
   )
 )
 (if ss
   (progn
     (setq n (sslength ss))
     (setq str	(strcat "\n" (itoa n) " blocs dans la sélection\n")
     )
     (repeat n
(setq bl  (vlax-ename->vla-object (ssname ss (setq n (1- n))))
      nom (if (vlax-property-available-p bl 'EffectiveName)
	    (vla-get-EffectiveName bl)
	    (vla-get-Name bl)
	  )
      lst (if (assoc nom lst)
	    (subst (cons nom (1+ (cdr (assoc nom lst))))
		   (assoc nom lst)
		   lst
	    )
	    (cons (cons nom 1) lst)
	  )
)
     )
     (setq str
     (apply 'strcat
	    (cons str
		  (mapcar
		    '(lambda (x)
		       (strcat (car x)
			       "\t"
			       (itoa (cdr x))
			       "\n"
		       )
		     )
		    lst
		  )
	    )
     )
     )
     (textscr)
     (princ str)
     (initget "Oui Non")
     (if
(= (getkword
     "\nEnregistrer dans un fichier ? [Oui/Non] : "
   )
   "Oui"
)
 (progn
   (setq
     file
      (open
	(getfiled "Créez ou sélectionnez un fichier"
		  ""
		  "xls"
		  1
	)
	"a"
      )
   )
   (princ str file)
   (close file)
 )
     )
     (graphscr)
   )
   (princ "\nAucune entité sélectionnée.")
 )
 (princ)
)

;; ZoomObject Effectue un zoom sur les objets contenus dans la liste
;;
;; Argument
;; objlst : une liste de vla-object
;;
;; Variables
;; dir : normale du plan de la vue courante
;; ang : angle de la vue courante
;; 3x3 : matrice de transformation du SCG vers la vue courante (dimension 3)
;; 4x4 : matrice de transformation du SCG vers la vue courante (dimension 4)
;; ptlst : liste des points minimum et maximum des bounding-boxes des objets sélectionnés (SCG)

(defun ZoomObject (objlst / dir ang 3x3 4x4 ptlst)
 (vl-load-com)
 (setq	dir (mapcar '-
	    (trans (getvar "viewdir") 1 0)
	    (trans '(0 0 0) 1 0)
    )
ang (- (getvar "viewtwist"))
3x3 (mxm (mapcar '(lambda (x) (trans x 0 dir))
		 '((1 0 0) (0 1 0) (0 0 1))
	 )
	 (list (list (cos ang) (- (sin ang)) 0)
	       (list (sin ang) (cos ang) 0)
	       '(0 0 1)
	 )
    )
4x4 (append
      (mapcar
	'(lambda (v o)
	   (append v (list o))
	 )
	3x3
	'(0 0 0)
      )
      (list '(0 0 0 1))
    )
 )
 (foreach obj objlst
   (vla-TransformBy obj (vlax-tmatrix (trp 4x4)))
   (vla-getBoundingBox obj 'minpt 'maxpt)
   (vla-TransformBy obj (vlax-tmatrix 4x4))
   (setq ptlst	(cons (vlax-safearray->list minpt)
	      (cons (vlax-safearray->list maxpt) ptlst)
	)
   )
 )
 (vla-ZoomWindow
   (vlax-get-acad-object)
   (vlax-3d-point (mxv 3x3 (apply 'mapcar (cons 'min ptlst))))
   (vlax-3d-point (mxv 3x3 (apply 'mapcar (cons 'max ptlst))))
 )
)

;; transpose une matrice Doug Wilson

(defun trp (m)
 (apply 'mapcar (cons 'list m))
)

;; Apply a transformation matrix to a vector by Vladimir Nesterovsky

(defun mxv (m v)
 (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)

;; Multiply two matrices by Vladimir Nesterovsky

(defun mxm (m q)
 (mapcar '(lambda (r) (mxv (trp q) r)) m)
)

;;; SelByObj -Gilles Chanteau- 06/10/06
;;; Crée un jeu de sélection avec tous les objets contenus ou  capturés,
;;; dans la vue courante, par un objet (cercle, ellipse, polyligne fermée)
;;; Arguments :
;;; - ent : un objet (ename ou vla-object) 
;;; - opt : un mode de sélection (Cp ou Wp)
;;; - fltr : un filtre de sélection (liste) ou nil

(defun SelByObj	(ent opt fltr / obj dist n lst prec dist p_lst ss)
 (vl-load-com)
 (if (= (type ent) 'ENAME)
   (setq obj (vlax-ename->vla-object ent))
   (setq obj ent
  ent (vlax-vla-object->ename ent)
   )
 )
 (cond
   ((member (vla-get-ObjectName obj) '("AcDbCircle" "AcDbEllipse"))
    (setq dist	(/ (vlax-curve-getDistAtParam
	     obj
	     (vlax-curve-getEndParam obj)
	   )
	   50
	)
   n	0
    )
    (repeat 50
      (setq
 lst
  (cons
    (trans
      (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
      0
      1
    )
    lst
  )
      )
    )
   )
   ((and (= (vla-get-ObjectName obj) "AcDbPolyline")
  (= (vla-get-Closed obj) :vlax-true)
  )
    (setq p_lst (vl-remove-if-not
	   '(lambda (x)
	      (or (= (car x) 10)
		  (= (car x) 42)
	      )
	    )
	   (entget ent)
	 )
    )
    (while p_lst
      (setq
 lst
  (cons
    (trans (append (cdr (assoc 10 p_lst))
			 (list (cdr (assoc 38 (entget ent))))
		 )
		 ent
		 1
    )
    lst
  )
      )
      (if (/= 0 (cdadr p_lst))
 (progn
   (setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
	 dist (/ (- (if	(cdaddr p_lst)
		      (vlax-curve-getDistAtPoint
			obj
			(trans (cdaddr p_lst) ent 0)
		      )
		      (vlax-curve-getDistAtParam
			obj
			(vlax-curve-getEndParam obj)
		      )
		    )
		    (vlax-curve-getDistAtPoint
		      obj
		      (trans (cdar p_lst) ent 0)
		    )
		 )
		 prec
	      )
	 n    0
   )
   (repeat (1- prec)
     (setq
       lst (cons
	     (trans
		 (vlax-curve-getPointAtDist
		   obj
		   (+ (vlax-curve-getDistAtPoint
			obj
			(trans (cdar p_lst) ent 0)
		      )
		      (* dist (setq n (1+ n)))
		   )
		 )
		 0
		 1
	       )
	     lst
	   )
     )
   )
 )
      )
      (setq p_lst (cddr p_lst))
    )
   )
 )
 (cond
   (lst
    (setq ss (ssget (strcat "_" opt) lst fltr))
    ss
   )
 )
) 

Gilles Chanteau - gileCAD - GitHub
Développements sur mesure pour AutoCAD

Créer un compte ou se connecter pour commenter

Vous devez être membre afin de pouvoir déposer un commentaire

Créer un compte

Créez un compte sur notre communauté. C’est facile !

Créer un nouveau compte

Se connecter

Vous avez déjà un compte ? Connectez-vous ici.

Connectez-vous maintenant
×
×
  • Créer...

Information importante

Nous avons placé des cookies sur votre appareil pour aider à améliorer ce site. Vous pouvez choisir d’ajuster vos paramètres de cookie, sinon nous supposerons que vous êtes d’accord pour continuer. Politique de confidentialité